diff --git a/code/defmacro.lisp b/code/defmacro.lisp
index e9f48251f1dcf500827cb2c80bfe4d26fa3fb9a0..19bcfbc4a4027bcc8727b5a2eb0fd801879a965d 100644
--- a/code/defmacro.lisp
+++ b/code/defmacro.lisp
@@ -46,7 +46,8 @@
 				   (doc-string-allowed t)
 				   ((:environment env-arg-name))
 				   ((:default-default *default-default*))
-				   ((:key-finder *key-finder*)))
+				   ((:key-finder *key-finder*))
+				   error-fun)
   "Returns as multiple-values a parsed body, any local-declarations that
    should be made where this body is inserted, and a doc-string if there is
    one."
@@ -58,7 +59,7 @@
       (multiple-value-bind
 	  (env-arg-used minimum maximum)
 	  (parse-defmacro-lambda-list lambda-list arg-list-name name
-				      error-kind (not annonymousp)
+				      error-kind error-fun (not annonymousp)
 				      nil env-arg-name)
 	(values
 	 `(let* ,(nreverse *system-lets*)
@@ -74,8 +75,9 @@
 	 maximum)))))
 
 
-(defun parse-defmacro-lambda-list (lambda-list arg-list-name name error-kind
-			  &optional top-level env-illegal env-arg-name)
+(defun parse-defmacro-lambda-list
+       (lambda-list arg-list-name name error-kind error-fun
+		    &optional top-level env-illegal env-arg-name)
   (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
 	(now-processing :required)
 	(maximum 0)
@@ -190,7 +192,7 @@
 		    (push-sub-list-binding sub-list-name `(car ,path) var
 					   name error-kind)
 		    (parse-defmacro-lambda-list var sub-list-name name
-						error-kind))
+						error-kind error-fun))
 		  (setf path `(cdr ,path))
 		  (incf minimum)
 		  (incf maximum))
@@ -202,7 +204,7 @@
 			    var))
 		  (push-optional-binding (car var) (cadr var) (caddr var)
 					 `(not (null ,path)) `(car ,path)
-					 name error-kind)
+					 name error-kind error-fun)
 		  (setf path `(cdr ,path))
 		  (incf maximum))
 		 (:keywords
@@ -219,21 +221,24 @@
 								,rest-name)
 					   `(keyword-argument ,keyword
 							      ,rest-name)
-					   name error-kind)
+					   name error-kind error-fun)
 		    (push keyword keys)))
 		 (:auxs (push-let-binding (car var) (cadr var) nil)))))))
-    (push `(destructuring-arg-count-test ,(if top-level
-					      `(cdr ,arg-list-name)
-					      arg-list-name)
-					 ,minimum
-					 ,(or (not (null restp)) maximum)
-					 ',lambda-list
-					 ',name
-					 ',error-kind)
+    (push `(verify-arg-counts ,(if top-level
+				   `(cdr ,arg-list-name)
+				   arg-list-name)
+			      ,minimum
+			      ,(or (not (null restp)) maximum)
+			      ',lambda-list
+			      ',name
+			      ',error-kind
+			      ,@(if error-fun `(#',error-fun)))
 	  *arg-tests*)
     (if keys
-	(push `(destructuring-key-test ,rest-name
-				       ,(if allow-other-keys-p t `',keys))
+	(push `(verify-valid-keys ,rest-name
+				  ,(if allow-other-keys-p t `',keys)
+				  ',name ',error-kind
+				  ,@(if error-fun `(#',error-fun)))
 	      *arg-tests*))
     (values env-arg-used minimum (if (null restp) maximum nil))))
 
@@ -255,66 +260,79 @@
 	(push let-form *user-lets*))))
 
 (defun push-optional-binding (value-var init-form supplied-var condition path
-					name error-kind)
+					name error-kind error-fun)
   (unless supplied-var
     (setf supplied-var (gensym "SUPLIEDP-")))
   (push-let-binding supplied-var condition t)
   (cond ((consp value-var)
 	 (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
 	   (push-let-binding whole-thing path t supplied-var init-form)
-	   (parse-defmacro-lambda-list value-var whole-thing name error-kind)))
+	   (parse-defmacro-lambda-list value-var whole-thing name
+				       error-kind error-fun)))
 	((symbolp value-var)
 	 (push-let-binding value-var path nil supplied-var init-form))
 	(t
 	 (error "Illegal optional variable name: ~S" value-var))))
 
-(defun defmacro-error (location kind)
-  (error "Illegal or ill-formed ~A argument in ~S." kind location))
+(defun defmacro-error (name kind)
+  (error "Illegal or ill-formed ~A argument in ~S." kind name))
 
 
 
 ;;;; Destructuring argument testing routines.
 
-(proclaim '(inline destructuring-arg-count-error))
-;;;
-(defun destructuring-arg-count-error (string name error-kind &rest args)
-  (error "While expanding ~A ~A:~%  ~?" error-kind name string args))
-
 ;;; DESTRUCTURING-ARG-COUNT-TEST tests an argument list against a maximum
 ;;; and minimum number of arguments.  NIL for maximum means there is no
 ;;; limit.  Keywords are checked.  T for keylist means allow-other-keys.
 ;;;
-(defun destructuring-arg-count-test (arg-list minimum maximum lambda-list
-					      name error-kind)
+(defun verify-arg-counts
+       (arg-list minimum maximum lambda-list name error-kind
+		 &optional (error-fun #'destructuring-arg-count-error))
   (unless (listp arg-list)
-    (destructuring-arg-count-error
-     "~S should have been a list of arguments for lambda-list ~S."
-     name error-kind arg-list lambda-list))
+    (funcall error-fun nil
+	     "~S should have been a list of arguments for lambda-list ~S."
+	     name error-kind arg-list lambda-list))
   (let ((length (length arg-list)))
     (cond ((< length minimum)
-	   (destructuring-arg-count-error
-	    "Too few arguments in ~S to satisfy lambda-list ~S.~%  Expected at ~
-	    least ~D."
-	    name error-kind arg-list lambda-list minimum))
+	   (funcall error-fun nil
+		    "Too few arguments in ~S to satisfy lambda-list ~S.~%  ~
+		    Expected at least ~D."
+		    name error-kind arg-list lambda-list minimum))
 	  ((and (not (eq maximum t))
 		(> length maximum))
-	   (destructuring-arg-count-error
-	    "Too many arguments in ~S to satisfy lambda-list ~S.~%  Expected ~
-	    no more than ~D."
-	    name error-kind arg-list lambda-list maximum)))))
+	   (funcall error-fun nil
+		    "Too many arguments in ~S to satisfy lambda-list ~S.~%  ~
+		    Expected no more than ~D."
+		    name error-kind arg-list lambda-list maximum)))))
 
-(defun destructuring-key-test (key-bindings valid-keys)
+(defun verify-valid-keys
+       (key-bindings valid-keys name kind
+		     &optional (error-fun #'destructuring-arg-count-error))
   (when (keyword-argument :allow-other-keys key-bindings)
     (setf valid-keys t))
   (do ((test-key key-bindings (cddr test-key)))
       ((endp test-key))
     (let ((key (car test-key)))
-      (unless (and (keywordp key)
-		   (or (eq valid-keys t)
-		       (member key valid-keys)))
-	(cerror "Ignore it."
-		"~S is not an allowed keyword."
-		(car test-key))))))
+      (unless (keywordp key)
+	(funcall error-fun name kind "Ignore it." "Bogus keyword: ~S" key))
+      (unless (or (eq valid-keys t)
+		  (member key valid-keys))
+	(funcall error-fun name kind "Ignore it." "Unknown keyword: ~S" key)))))
+
+
+;;; DESTRUCTURING-ARG-COUNT-ERROR --- internal.
+;;;
+;;; Default error function for destructuring-arg-count-test.
+;;; 
+(defun destructuring-arg-count-error (name kind continue string &rest args)
+  (if continue
+      (cerror "~4*~?"
+	      "While expanding ~A ~S:~%  ~?"
+	      kind name string args
+	      continue args)
+      (error "While expanding ~A ~S:~%  ~?"
+	     kind name string args)))
+