diff --git a/code/describe.lisp b/code/describe.lisp
index bfcd0195576a7ddb8681accda939b5f0d89ec2ea..30fd374bcd18ba2743138ac713445ab9e48a55c1 100644
--- a/code/describe.lisp
+++ b/code/describe.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.38 2002/12/07 18:21:22 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.39 2003/02/05 11:08:45 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -112,8 +112,7 @@
     (array (describe-array x))
     (fixnum (describe-fixnum x))
     (cons
-     (if (and (eq (car x) 'setf) (consp (cdr x)) (null (cddr x))
-	      (symbolp (cadr x))
+     (if (and (valid-function-name-p x)
 	      (fboundp x))
 	 (describe-function (fdefinition x) :function x)
 	 (default-describe x)))
@@ -217,7 +216,7 @@
 	(*print-length* nil))
     (multiple-value-bind
 	(type where)
-	(if (or (symbolp name) (and (listp name) (eq (car name) 'setf)))
+	(if (valid-function-name-p name)
 	    (values (type-specifier (info function type name))
 		    (info function where-from name))
 	    (values type-spec :defined))
diff --git a/code/eval.lisp b/code/eval.lisp
index b153b2931288f88e52a0c81a6f78916b2271ca38..a5ff923a9560e2acdd690b8bfa81fa3a02f2424a 100644
--- a/code/eval.lisp
+++ b/code/eval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.34 2003/01/24 16:05:50 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.35 2003/02/05 11:08:45 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -173,7 +173,7 @@
 		     :format-arguments (list exp)))
 	    (let ((name (second exp)))
 	      (cond ((consp name)
-		     (if (eq (car name) 'setf)
+		     (if (valid-function-name-p name)
 			 (fdefinition name)
 			 (eval:make-interpreted-function name)))
 		    ((macro-function name)
diff --git a/code/exports.lisp b/code/exports.lisp
index b537f6333b4b150d496697dfb538b69c8f3e3ede..fb6681a67efb66101511fbde125c2e9aa20e8676 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.197 2003/01/26 22:09:38 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.198 2003/02/05 11:08:44 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1036,6 +1036,8 @@
 	     "PURIFY" "MAP-APROPOS"
 	     "*BATCH-MODE*"
 	     "COMPILER-LET"
+	     "DEFINE-FUNCTION-NAME-SYNTAX"
+	     "VALID-FUNCTION-NAME-P"
 
 	     ;; Gray streams extension.
 	     "FUNDAMENTAL-BINARY-STREAM" "FUNDAMENTAL-BINARY-INPUT-STREAM"
diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp
index 650f051eab79dbb544338426d7c6c2f8a63288cb..f4e7d0ae665e2458ea2d28d8f193cf2e4484006a 100644
--- a/code/fdefinition.lisp
+++ b/code/fdefinition.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.19 2001/12/10 02:53:16 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.20 2003/02/05 11:08:44 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -22,7 +22,8 @@
 (in-package "EXTENSIONS")
 
 (export '(encapsulate unencapsulate encapsulated-p
-	  basic-definition argument-list *setf-fdefinition-hook*))
+	  basic-definition argument-list *setf-fdefinition-hook*
+	  define-function-name-syntax valid-function-name-p))
 
 
 (in-package "KERNEL")
@@ -36,6 +37,56 @@
 (export '(fdefinition fboundp fmakunbound))
 
 
+
+;;;; Function names.
+
+(defvar *valid-function-names* ())
+
+(defun %define-function-name-syntax (name syntax-checker)
+  (let ((found (assoc name *valid-function-names* :test #'eq)))
+    (if found
+	(setf (cdr found) syntax-checker)
+	(setq *valid-function-names*
+	      (acons name syntax-checker *valid-function-names*)))))
+
+(defmacro define-function-name-syntax (name (var) &body body)
+  "Define (NAME ...) to be a valid function name whose syntax is checked
+  by BODY.  In BODY, VAR is bound to an actual function name of the
+  form (NAME ...) to check.  BODY should return two values.
+  First value true means the function name is valid.  Second value
+  is the name, a symbol, of the function for use in the BLOCK of DEFUNs
+  and in similar situations."
+  (let ((syntax-checker (symbolicate '%check- name '-function-name)))
+    `(progn
+       (defun ,syntax-checker (,var) ,@body)
+       (%define-function-name-syntax ',name #',syntax-checker))))
+
+(defun valid-function-name-p (name)
+  "First value is true if NAME has valid function name syntax.
+  Second value is the name, a symbol, to use as a block name in DEFUNs
+  and in similar situations."
+  (typecase name
+    (cons
+     (when (and (symbolp (car name))
+		(consp (cdr name)))
+       (let ((syntax-checker (cdr (assoc (car name) *valid-function-names*
+					 :test #'eq))))
+	 (when syntax-checker
+	   (funcall syntax-checker name)))))
+    (symbol (values t name))
+    (otherwise nil)))
+
+(define-function-name-syntax setf (name)
+  (destructuring-bind (setf fn &rest rest) name
+    (declare (ignore setf))
+    (when (null rest)
+      (typecase fn
+	(symbol
+	 (values t fn))
+	(cons
+	 (unless (eq 'setf (car fn))
+	   (valid-function-name-p fn)))))))
+
 
 ;;;; Fdefinition (fdefn) objects.
 
@@ -83,13 +134,7 @@
   "Return the fdefn object for NAME.  If it doesn't already exist and CREATE
    is non-NIL, create a new (unbound) one."
   (declare (values (or fdefn null)))
-  (unless (or (symbolp name)
-	      (and (consp name)
-		   (eq (car name) 'setf)
-		   (let ((cdr (cdr name)))
-		     (and (consp cdr)
-			  (symbolp (car cdr))
-			  (null (cdr cdr))))))
+  (unless (valid-function-name-p name)
     (error 'simple-type-error
 	   :datum name
 	   :expected-type '(or symbol list)
diff --git a/code/macros.lisp b/code/macros.lisp
index 64eb8597a57b4039cd7f3d01301db8028f6c7931..c3243ecbd928155fe6929f6804d20c9709e9181a 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.85 2003/01/23 21:05:34 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.86 2003/02/05 11:08:43 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -301,13 +301,12 @@
 ;;; lambda-list.
 ;;;
 (defmacro defun (&whole source name lambda-list &body (body decls doc))
-  (let ((def `(lambda ,lambda-list
-		,@decls
-		(block ,(if (and (consp name) (eq (car name) 'setf))
-			    (cadr name)
-			    name)
-		  ,@body))))
-    `(c::%defun ',name #',def ,doc ',source)))
+  (multiple-value-bind (valid block-name)
+      (valid-function-name-p name)
+    (let ((def `(lambda ,lambda-list
+		  ,@decls
+		  (block ,block-name ,@body))))
+      `(c::%defun ',name #',def ,doc ',source))))
 
 
 ;;; %Defun, %%Defun  --  Internal
diff --git a/code/profile.lisp b/code/profile.lisp
index 41379c4902144892c0c489fadae13b1490986c8d..9a523672c533f443b9d0c58a15a1d55aa4953c07 100644
--- a/code/profile.lisp
+++ b/code/profile.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.28 2003/01/26 22:09:02 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.29 2003/02/05 11:08:43 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -720,15 +720,14 @@ this, the functions are listed.  If NIL, then always list the functions.")
 		  "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
 		  (sort no-call #'string<
 			:key #'(lambda (n)
-				 (cond ((symbolp n)
-					(symbol-name n))
-				       ((and (listp n)
-					     (eq (car n) 'setf)
-					     (consp (cdr n))
-					     (symbolp (cadr n)))
-					(symbol-name (cadr n)))
-				       (t
-					(princ-to-string n))))))))
+				 (if (symbolp n)
+				     (symbol-name n)
+				     (multiple-value-bind (valid block-name)
+					 (ext:valid-function-name-p n)
+				       (declared (ignore valid))
+				       (if block-name
+					   block-name
+					   (princ-to-string n)))))))))
     (values)))
 
 
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index bd008c59bea724f195b8bba72c040b21a5c15429..4a8d7e643aed9a4c64a16c0f35ceb08c0c18d452 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.135 2003/01/06 15:10:17 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.136 2003/02/05 11:08:42 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2441,17 +2441,17 @@
       (case (car thing)
 	((lambda)
 	 (reference-leaf start cont (ir1-convert-lambda thing nil 'function)))
-	((setf)
-	 (let ((var (find-lexically-apparent-function
-		     thing "as the argument to FUNCTION")))
-	   (reference-leaf start cont var)))
 	((instance-lambda)
 	 (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
 					nil 'function)))
 	   (setf (getf (functional-plist res) :fin-function) t)
 	   (reference-leaf start cont res)))
 	(t
-	 (compiler-error "Illegal function name: ~S" thing)))
+	 (if (valid-function-name-p thing)
+	     (let ((var (find-lexically-apparent-function
+			 thing "as the argument to FUNCTION")))
+	       (reference-leaf start cont var))
+	     (compiler-error "Illegal function name: ~S" thing))))
       (let ((var (find-lexically-apparent-function
 		  thing "as the argument to FUNCTION")))
 	(reference-leaf start cont var))))
diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index a3f530bb3ca08ec5856cabd49fe83626a87eab99..133debe3a82dc8c4164cdd31add0cd8b15743624 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.37 2002/07/22 17:02:43 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.38 2003/02/05 11:08:42 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -189,9 +189,7 @@
 (defun check-function-name (name)
   (typecase name
     (list
-     (unless (and (consp name) (consp (cdr name))
-		  (null (cddr name)) (eq (car name) 'setf)
-		  (symbolp (cadr name)))
+     (unless (valid-function-name-p name)
        (compiler-error "Illegal function name: ~S." name))
      name)
     (symbol