diff --git a/collects/scheme/private/kw.ss b/collects/scheme/private/kw.ss
index 09f93893d1..4d4eb767ca 100644
--- a/collects/scheme/private/kw.ss
+++ b/collects/scheme/private/kw.ss
@@ -14,9 +14,10 @@
   (#%provide new-lambda new-λ
              new-define
              new-app
-             (rename *make-keyword-procedure make-keyword-procedure)
+             make-keyword-procedure
              keyword-apply
              procedure-keywords
+             new:procedure-reduce-arity
              procedure-reduce-keyword-arity
              new-prop:procedure
              new:procedure->method
@@ -25,7 +26,7 @@
   
   ;; ----------------------------------------
 
-  (define-values (struct:keyword-procedure make-keyword-procedure keyword-procedure?
+  (define-values (struct:keyword-procedure mk-kw-proc keyword-procedure?
                                            keyword-procedure-ref keyword-procedure-set!)
     (make-struct-type 'keyword-procedure #f 4 0 #f
                       (list (cons prop:checked-procedure #t))
@@ -113,7 +114,7 @@
                       struct:okp
                       0 0 #f))
 
-  (define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name)
+  (define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name+fail)
     (make-struct-type-property 'named-keyword-procedure))
 
   ;; Constructor generator for a procedure with a required keyword.
@@ -123,13 +124,15 @@
   ;;  the right arity, and that sends all arguments to `missing-kw'.
   (define (make-required name fail-proc method?)
     (let-values ([(s: mk ? -ref -set!)
-                  (make-struct-type (string->symbol (format "procedure:~a" name))
+                  (make-struct-type (or name 'unknown)
                                     (if method?
                                         struct:keyword-method
                                         struct:keyword-procedure)
                                     0 0 #f
-                                    (list (cons prop:arity-string generate-arity-string)
-                                          (cons prop:named-keyword-procedure name))
+                                    (list (cons prop:arity-string 
+                                                generate-arity-string)
+                                          (cons prop:named-keyword-procedure 
+                                                (cons name fail-proc)))
                                     (current-inspector) fail-proc)])
       mk))
 
@@ -140,21 +143,19 @@
   
   ;; ----------------------------------------
 
-  (define *make-keyword-procedure
-    (letrec ([make-keyword-procedure
-              (case-lambda 
-                [(proc) (make-keyword-procedure 
-                         proc
-                         (lambda args
-                           (apply proc null null args)))]
-                [(proc plain-proc)
-                 (make-optional-keyword-procedure
-                  (make-keyword-checker null #f (procedure-arity proc))
-                  proc
-                  null
-                  #f
-                  plain-proc)])])
-      make-keyword-procedure))
+  (define make-keyword-procedure
+    (case-lambda 
+     [(proc) (make-keyword-procedure 
+              proc
+              (lambda args
+                (apply proc null null args)))]
+     [(proc plain-proc)
+      (make-optional-keyword-procedure
+       (make-keyword-checker null #f (procedure-arity proc))
+       proc
+       null
+       #f
+       plain-proc)]))
                          
   (define (keyword-apply proc kws kw-vals . normal-argss)
     (let ([type-error
@@ -943,7 +944,7 @@
                               raise-type-error 'x "x" 0 'x
                               (append args (apply append (map list kws kw-args))))))]
                       [proc-name (lambda (p) (or (and (named-keyword-procedure? p)
-                                                      (keyword-procedure-name p))
+                                                      (car (keyword-procedure-name+fail p)))
                                                  (object-name p)
                                                  p))])
                   (raise
@@ -986,13 +987,6 @@
            [(null? (cdr kws)) #t]
            [(keyword<? (car kws) (cadr kws)) (loop (cdr kws))]
            [else #f])))
-      (define (subset? a b)
-        (cond
-         [(null? a) #t]
-         [(null? b) #f]
-         [(eq? (car a) (car b)) (subset? (cdr a) (cdr b))]
-         [(keyword<? (car a) (car b)) #f]
-         [else (subset? a (cdr b))]))
 
       (unless (and (list? req-kw) (andmap keyword? req-kw)
                    (sorted? req-kw))
@@ -1054,7 +1048,7 @@
                 ;; Some keywords are required, so "plain" proc is
                 ;;  irrelevant; we build a new one that wraps `missing-kws'.
                 ((make-required (or (and (named-keyword-procedure? proc)
-                                         (keyword-procedure-name proc))
+                                         (car (keyword-procedure-name+fail proc)))
                                     (object-name proc))
                                 (procedure-reduce-arity 
                                  missing-kw
@@ -1065,11 +1059,45 @@
                  new-kw-proc
                  req-kw
                  allowed-kw))))))
+
+  (define new:procedure-reduce-arity
+    (let ([procedure-reduce-arity
+           (lambda (proc arity)
+             (if (and (procedure? proc)
+                      (keyword-procedure? proc)
+                      (not (okp? proc))
+                      (not (null? arity)))
+                 (raise-mismatch-error 'procedure-reduce-arity
+                                       "procedure has required keyword arguments: "
+                                       proc)
+                 (procedure-reduce-arity proc arity)))])
+      procedure-reduce-arity))
     
   (define new:procedure->method
     (let ([procedure->method
            (lambda (proc)
-             (procedure->method proc))])
+             (if (keyword-procedure? proc)
+                 (cond
+                  [(okm? proc) proc]
+                  [(keyword-method? proc) proc]
+                  [(okp? proc) (make-optional-keyword-method
+                                (keyword-procedure-checker proc)
+                                (keyword-procedure-proc proc)
+                                (keyword-procedure-required proc)
+                                (keyword-procedure-allowed proc)
+                                (okp-ref proc 0))]
+                  [else
+                   ;; Constructor must be from `make-required', but not a method.
+                   ;; Make a new variant that's a method:
+                   (let* ([name+fail (keyword-procedure-name+fail proc)]
+                          [mk (make-required (car name+fail) (cdr name+fail) #t)])
+                     (mk
+                      (keyword-procedure-checker proc)
+                      (keyword-procedure-proc proc)
+                      (keyword-procedure-required proc)
+                      (keyword-procedure-allowed proc)))])
+                 ;; Not a keyword-accepting procedure:
+                 (procedure->method proc)))])
       procedure->method))
 
   (define new:procedure-rename
@@ -1078,11 +1106,130 @@
              (if (not (and (keyword-procedure? proc)
                            (symbol? name)))
                  (procedure-rename proc name)
-                 (procedure-rename proc name)))])
+                 ;; Rename a keyword procedure:
+                 (cond
+                  [(okp? proc)
+                   ((if (okm? proc)
+                        make-optional-keyword-procedure
+                        make-optional-keyword-method)
+                    (keyword-procedure-checker proc)
+                    (keyword-procedure-proc proc)
+                    (keyword-procedure-required proc)
+                    (keyword-procedure-allowed proc)
+                    (procedure-rename (okp-ref proc 0) name))]
+                  [else
+                   ;; Constructor must be from `make-required':
+                   (let* ([name+fail (keyword-procedure-name+fail proc)]
+                          [mk (make-required name (cdr name+fail) (keyword-method? proc))])
+                     (mk
+                      (keyword-procedure-checker proc)
+                      (keyword-procedure-proc proc)
+                      (keyword-procedure-required proc)
+                      (keyword-procedure-allowed proc)))])))])
       procedure-rename))
 
   (define new:chaperone-procedure
     (let ([chaperone-procedure 
            (lambda (proc wrap-proc . props)
-             (apply chaperone-procedure proc wrap-proc props))])
+             (if (or (not (keyword-procedure? proc))
+                     (not (procedure? wrap-proc)))
+                 (apply chaperone-procedure proc wrap-proc props)
+                 (let-values ([(a) (procedure-arity proc)]
+                              [(b) (procedure-arity wrap-proc)]
+                              [(a-req a-allow) (procedure-keywords proc)]
+                              [(b-req b-allow) (procedure-keywords wrap-proc)])
+                   (define (includes? a b)
+                     (cond
+                      [(number? b) (cond
+                                    [(number? a) (= b a)]
+                                    [(arity-at-least? a)
+                                     (b . >= . (arity-at-least-value a))]
+                                    [else
+                                     (ormap (lambda (b a) (includes? a b))
+                                            a)])]
+                      [(arity-at-least? b) (cond
+                                            [(number? a) #f]
+                                            [(arity-at-least? a)
+                                             ((arity-at-least-value b) . >= . (arity-at-least-value a))]
+                                            [else (ormap (lambda (b a) (includes? b a))
+                                                         a)])]
+                      [else (andmap (lambda (b) (includes? a b)) b)]))
+
+                   (unless (includes? b a)
+                     ;; Let core report error:
+                     (apply chaperone-procedure proc wrap-proc props))
+                   (unless (subset? b-req a-req)
+                     (raise-mismatch-error
+                      'chaperone-procedure
+                      "chaperoning procedure requires more keywords than original procedure: "
+                      proc))
+                   (unless (or (not b-allow)
+                               (and a-allow
+                                    (subset? a-allow b-allow)))
+                     (raise-mismatch-error
+                      'chaperone-procedure
+                      "chaperoning procedure does not accept all keywords of original procedure: "
+                      proc))
+                   (let* ([kw-chaperone
+                           (let ([p (keyword-procedure-proc wrap-proc)])
+                             (lambda (kws args . rest)
+                               (call-with-values (lambda () (apply p kws args rest))
+                                 (lambda results
+                                   (let ([len (length results)]
+                                         [alen (length rest)])
+                                     (unless (<= (+ alen 1) len (+ alen 2))
+                                       (raise-mismatch-error
+                                        '|keyword procedure chaperone|
+                                        (format
+                                         "expected ~a or ~a results, received ~a results from chaperoning procedure: "
+                                         (+ alen 1)
+                                         (+ alen 2)
+                                         len)
+                                        wrap-proc))
+                                     (let ([new-args (car results)])
+                                       (unless (and (list? new-args)
+                                                    (= (length new-args) (length args)))
+                                         (raise-mismatch-error
+                                          '|keyword procedure chaperone|
+                                          "expected a list of keyword-argument values as first result from chaperoning procedure: "
+                                          wrap-proc))
+                                       (for-each
+                                        (lambda (kw new-arg arg)
+                                          (unless (chaperone-of? new-arg arg)
+                                            (raise-mismatch-error
+                                             '|keyword procedure chaperone|
+                                             (format
+                                              "~a keyword result is not a chaperone of original argument from chaperoning procedure: "
+                                              kw)
+                                             wrap-proc)))
+                                        kws
+                                        new-args
+                                        args))
+                                   (apply values kws results))))))]
+                          [new-proc
+                           (cond
+                            [(okp? proc)
+                             (make-optional-keyword-procedure
+                              (keyword-procedure-checker proc)
+                              (chaperone-procedure (keyword-procedure-proc proc)
+                                                   kw-chaperone)
+                              (keyword-procedure-required proc)
+                              (keyword-procedure-allowed proc)
+                              (chaperone-procedure (okp-ref proc 0)
+                                                   (okp-ref wrap-proc 0)))]
+                            [else
+                             ;; Constructor must be from `make-required':
+                             (let* ([name+fail (keyword-procedure-name+fail proc)]
+                                    [mk (make-required (car name+fail) (cdr name+fail) (keyword-method? proc))])
+                               (mk
+                                (keyword-procedure-checker proc)
+                                (chaperone-procedure (keyword-procedure-proc proc) kw-chaperone)
+                                (keyword-procedure-required proc)
+                                (keyword-procedure-allowed proc)))])])
+                     (if (null? props)
+                         new-proc
+                         (apply chaperone-struct new-proc 
+                                ;; chaperone-struct insists on having at least one selector:
+                                keyword-procedure-allowed values
+                                props))))))])
       chaperone-procedure)))
diff --git a/collects/scheme/private/pre-base.ss b/collects/scheme/private/pre-base.ss
index ee2bc2fd32..6984f83c59 100644
--- a/collects/scheme/private/pre-base.ss
+++ b/collects/scheme/private/pre-base.ss
@@ -73,11 +73,12 @@
              (rename module-begin #%module-begin)
              (rename norm:procedure-arity procedure-arity)
              (rename norm:raise-arity-error raise-arity-error)
+             (rename new:procedure-reduce-arity procedure-reduce-arity)
              (rename new:procedure->method procedure->method)
              (rename new:procedure-rename procedure-rename)
              (rename new:chaperone-procedure chaperone-procedure)
              (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure 
-                              procedure-arity raise-arity-error
+                              procedure-arity procedure-reduce-arity raise-arity-error
                               procedure->method procedure-rename
                               chaperone-procedure)
              (all-from "reqprov.ss")
diff --git a/collects/scribblings/inside/eval.scrbl b/collects/scribblings/inside/eval.scrbl
index 8b402766d0..0e5be83fee 100644
--- a/collects/scribblings/inside/eval.scrbl
+++ b/collects/scribblings/inside/eval.scrbl
@@ -186,7 +186,10 @@ to create new namespaces.}
            [int c]
            [Scheme_Object** args])]{
 
-Applies the procedure @var{f} to the given arguments.}
+Applies the procedure @var{f} to the given arguments.
+
+Beware that the procedure can mutate @var{args} if it is the same as
+the result of @cpp{scheme_current_argument_stack}.}
 
 @function[(Scheme_Object* scheme_apply_multi
            [Scheme_Object* f]
diff --git a/collects/scribblings/inside/procedures.scrbl b/collects/scribblings/inside/procedures.scrbl
index 8d2358c4ad..bc07c8a5c6 100644
--- a/collects/scribblings/inside/procedures.scrbl
+++ b/collects/scribblings/inside/procedures.scrbl
@@ -17,7 +17,9 @@ of arguments passed to the function will be checked using the arity
 information.  (The arity information provided to
 @cpp{scheme_make_prim_w_arity} is also used for the Scheme
 @scheme[arity] procedure.) The procedure implementation is not allowed
-to mutate the input array of arguments, although it may mutate the
+to mutate the input array of arguments; as an exception, the procedure
+can mutate the array if it is the same a the result of
+@cpp{scheme_current_argument_stack}. The procedure may mutate the
 arguments themselves when appropriate (e.g., a fill in a vector
 argument).
 
@@ -129,3 +131,12 @@ The form of @var{prim} is defined by:
 
 Creates a closed primitive procedure value without arity information.
 This function is provided for backward compatibility only.}
+
+@function[(Scheme_Object** scheme_current_argument_stack)]{
+
+Returns a pointer to an internal stack for argument passing. When the
+argument array passed to a procedure corresponds to the current
+argument stack address, the procedure is allowed to modify the
+array. In particular, it might clear out pointers in the argument
+array to allow the arguments to be reclaimed by the memory manager (if
+they are not otherwise accessible).}
diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl
index ac71113d2a..7e0fdb0c45 100644
--- a/collects/scribblings/reference/chaperones.scrbl
+++ b/collects/scribblings/reference/chaperones.scrbl
@@ -89,24 +89,39 @@ from @scheme[v1] through one of the chaperone constructors (e.g.,
          (and/c procedure? chaperone?)]{
 
 Returns a chaperoned procedure that has the same arity, name, and
-other attributes as @scheme[proc]. The arity of @scheme[wrapper-proc]
-must include the arity of @scheme[proc]; when the chaperoned procedure
-is applied, the arguments are first passed to @scheme[wrapper-proc].
+other attributes as @scheme[proc]. When the chaperoned procedure is
+applied, the arguments are first passed to @scheme[wrapper-proc], and
+then the results from @scheme[wrapper-proc] are passed to
+@scheme[proc]. The @scheme[wrapper-proc] can also supply a procedure
+that processes the results of @scheme[proc].
 
-The result of @scheme[wrapper-proc] must be either the same number of
-values as supplied to it or one more than the number of supplied
-values. For each supplied value, the corresponding result must be the
-same or a chaperone of (in the sense of @scheme[chaperone-of?]) the
-supplied value. The additional result, if any, must be a procedure
-that accepts as many results as produced by @scheme[proc]; it must
-return the same number of results, each of which is the same or a
-chaperone of the corresponding original result.
+The arity of @scheme[wrapper-proc] must include the arity of
+@scheme[proc]. The allowed keyword arguments of @scheme[wrapper-proc]
+must be a superset of the allowed keywords of @scheme[proc]. The
+required keyword arguments of @scheme[wrapper-proc] must be a subset
+of the required keywords of @scheme[proc].
 
+For applications without keywords, the result of @scheme[wrapper-proc]
+must be either the same number of values as supplied to it or one more
+than the number of supplied values. For each supplied value, the
+corresponding result must be the same or a chaperone of (in the sense
+of @scheme[chaperone-of?]) the supplied value. The additional result,
+if any, must be a procedure that accepts as many results as produced
+by @scheme[proc]; it must return the same number of results, each of
+which is the same or a chaperone of the corresponding original result.
 If @scheme[wrapper-proc] returns the same number of values as it is
 given (i.e., it does not return a procedure to chaperone
 @scheme[proc]'s result), then @scheme[proc] is called in @tech{tail
 position} with respect to the call to the chaperone.
 
+For applications that include keyword arguments, @scheme[wrapper-proc]
+must return an additional value before any other values. The
+additional value must be a list of chaperones of the keyword arguments
+that were supplied to the chaperoned procedure (i.e., not counting
+optional arguments that were not supplied). The arguments must be
+ordered according to the sorted order of the supplied arguments'
+keywords.
+
 Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
 to @scheme[procedure-chaperone] must be even) add chaperone properties
 or override chaperone-property values of @scheme[proc].}
diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl
index a2d4b5cf5f..ecf93afbf5 100644
--- a/collects/scribblings/reference/procedures.scrbl
+++ b/collects/scribblings/reference/procedures.scrbl
@@ -176,8 +176,13 @@ when @scheme[procedure-arity] is applied to the generated
 procedure, it returns a value that is @scheme[equal?] to
 @scheme[arity].
 
-If the @scheme[arity] specification allows arguments that are not
-in @scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract].
+If the @scheme[arity] specification allows arguments that are not in
+@scheme[(procedure-arity proc)], the @exnraise[exn:fail:contract].  If
+@scheme[proc] accepts keyword argument, either the keyword arguments
+must be all optional (and they are not accepted in by the
+arity-reduced procedure) or @scheme[arity] must be the empty list
+(which makes a procedure that cannot be called); otherwise, the
+@exnraise[exn:fail:contract].
 
 @examples[
 (define my+ (procedure-reduce-arity + 2))
diff --git a/collects/scribblings/reference/struct-inspectors.scrbl b/collects/scribblings/reference/struct-inspectors.scrbl
index e193e33860..e96795ff1d 100644
--- a/collects/scribblings/reference/struct-inspectors.scrbl
+++ b/collects/scribblings/reference/struct-inspectors.scrbl
@@ -150,8 +150,11 @@ The name (if any) of a procedure is always a symbol. The
 name.
 
 The name of a @tech{structure}, @tech{structure type}, @tech{structure
-type property} is always a symbol. If a @tech{structure} is not a
-procedure, its name matches the name of the @tech{structure type} that
+type property} is always a symbol. If a @tech{structure} is a
+procedure as implemented by one of its fields (i.e., the
+@scheme[prop:procedure] property value for the structure's type is an
+integer), then its name is the implementing procedure's name;
+otherwise, its name matches the name of the @tech{structure type} that
 it instantiates.
 
 The name of a @tech{regexp value} is a string or byte string. Passing
diff --git a/collects/tests/future/random-future.ss b/collects/tests/future/random-future.ss
index a9659b290c..53b74c9526 100644
--- a/collects/tests/future/random-future.ss
+++ b/collects/tests/future/random-future.ss
@@ -182,7 +182,7 @@ Errors/exceptions and other kinds of control?
                (gen-exp))]))
 
 (define-namespace-anchor ns-here)
-(let ([seed (+ 1 (random (expt 2 30)))])
+(let ([seed 595933061 #;(+ 1 (random (expt 2 30)))])
   (printf "DrDr Ignore! random-seed ~s\n" seed)
   (random-seed seed))
 
diff --git a/collects/tests/mzscheme/chaperone.ss b/collects/tests/mzscheme/chaperone.ss
index d3e22b0af1..73f3a592a8 100644
--- a/collects/tests/mzscheme/chaperone.ss
+++ b/collects/tests/mzscheme/chaperone.ss
@@ -172,6 +172,56 @@
   (test (vector 'a 'b 'c) values in)
   (test (vector 'b '(a c)) values out))
 
+;; Optional keyword arguments:
+(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
+       [in #f]
+       [f2 (chaperone-procedure
+            f
+            (lambda (x #:a [a 'nope] #:b [b 'nope])
+              (if (and (eq? a 'nope) (eq? b 'nope))
+                  x
+                  (values
+                   (append 
+                    (if (eq? a 'nope) null (list a))
+                    (if (eq? b 'nope) null (list b)))
+                   x))))])
+  (test '(1 a b) f 1)
+  (test '(1 a b) f2 1)
+  (test '(1 2 b) f 1 #:a 2)
+  (test '(1 2 b) f2 1 #:a 2)
+  (test '(1 a 3) f 1 #:b 3)
+  (test '(1 a 3) f2 1 #:b 3)
+  (test '(1 2 3) f 1 #:a 2 #:b 3)
+  (test '(1 2 3) f2 1 #:a 2 #:b 3)
+  (test 1 procedure-arity f2)
+  (test 'f object-name f2)
+  (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))))
+
+;; Required keyword arguments:
+(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
+       [in #f]
+       [f2 (chaperone-procedure
+            f
+            (lambda (x #:a [a 'nope] #:b [b 'nope])
+              (if (and (eq? a 'nope) (eq? b 'nope))
+                  x
+                  (values
+                   (append 
+                    (if (eq? a 'nope) null (list a))
+                    (if (eq? b 'nope) null (list b)))
+                   x))))])
+  (err/rt-test (f 1))
+  (err/rt-test (f2 1))
+  (err/rt-test (f 1 #:a 2))
+  (err/rt-test (f2 1 #:a 2))
+  (test '(1 a 3) f 1 #:b 3)
+  (test '(1 a 3) f2 1 #:b 3)
+  (test '(1 2 3) f 1 #:a 2 #:b 3)
+  (test '(1 2 3) f2 1 #:a 2 #:b 3)
+  (test 1 procedure-arity f2)
+  (test 'f object-name f2)
+  (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))))
+
 (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
 (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1))
 (err/rt-test ((chaperone-procedure (lambda (x) (values x x)) (lambda (y) y))) 1)
diff --git a/collects/tests/mzscheme/procs.ss b/collects/tests/mzscheme/procs.ss
index 0d2991a598..4b665ab46f 100644
--- a/collects/tests/mzscheme/procs.ss
+++ b/collects/tests/mzscheme/procs.ss
@@ -65,160 +65,190 @@
     (,f_0_2+ ,(list 0 (make-arity-at-least 2)) () ())
     (,f1:+ 1 () #f)))
 
-(for-each (lambda (p)
-            (let ([a (cadr p)])
-              (test a procedure-arity (car p))
-              (test-values (list (caddr p) (cadddr p))
-                           (lambda ()
-                             (procedure-keywords (car p))))
-              (let ([1-ok? (let loop ([a a])
-                             (or (equal? a 1)
-                                 (and (arity-at-least? a)
-                                      ((arity-at-least-value a) . <= . 1))
-                                 (and (list? a)
-                                      (ormap loop a))))])
-                (test 1-ok? procedure-arity-includes? (car p) 1)
-                (let ([allowed (cadddr p)]
-                      [required (caddr p)])
-                  ;; If some keyword is required, make sure that a plain
-                  ;;  application fails:
-                  (unless (null? required)
-                    (err/rt-test
-                     (apply (car p) (make-list (procedure-arity (car p)) #\0))))
-                  ;; Other tests:
-                  (if 1-ok?
-                      (cond
-                       [(equal? allowed '())
-                        (test (let ([auto (cddddr p)])
-                                (cond
-                                 [(equal? auto '((#:a #:b))) '(1 0 1)]
-                                 [(equal? auto '((#:a))) '(1 0)]
-                                 [(equal? auto '((#:a))) '(1 0)]
-                                 [else '(1)]))
-                              (car p) 1)
-                        (err/rt-test ((car p) 1 #:a 0))
-                        (err/rt-test ((car p) 1 #:b 0))
-                        (err/rt-test ((car p) 1 #:a 0 #:b 0))]
-                       [(equal? allowed '(#:a))
-                        (test (if (pair? (cddddr p)) 
-                                  '(10 20 1) ; dropped #:b
-                                  '(10 20))
-                              (car p) 10 #:a 20)
-                        (err/rt-test ((car p) 1 #:b 0))
-                        (err/rt-test ((car p) 1 #:a 0 #:b 0))]
-                       [(equal? allowed '(#:b))
-                        (test '(10.0 20.0) (car p) 10.0 #:b 20.0)
-                        (err/rt-test ((car p) 1 #:a 0))
-                        (err/rt-test ((car p) 1 #:a 0 #:b 0))]
-                       [(equal? allowed '(#:a #:b))
-                        (test '(100 200 300) (car p) 100 #:b 300 #:a 200)
-                        (err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))]
-                       [(equal? allowed #f)
-                        (test '(1 2 3) (car p) 1 #:b 3 #:a 2)])
-                      (begin
-                        ;; Try just 1:
-                        (err/rt-test ((car p) 1))
-                        ;; Try with right keyword args, to make sure the by-position
-                        ;; arity is checked:
-                        (cond
-                         [(equal? allowed '())
-                          (void)]
-                         [(equal? allowed '(#:a))
-                          (err/rt-test ((car p) 1 #:a 1))]
-                         [(equal? allowed '(#:b))
-                          (err/rt-test ((car p) 1 #:b 1))]
-                         [(equal? allowed '(#:a #:b))
-                          (err/rt-test ((car p) 1 #:a 1 #:b 1))]
-                         [(equal? allowed #f)
-                          (err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
-          (append procs
-                  ;; reduce to arity 1 or nothing:
-                  (map (lambda (p)
-                         (let ([p (car p)])
-                           (let-values ([(req allowed) (procedure-keywords p)])
-                             (if (null? allowed)
-                                 (if (procedure-arity-includes? p 1)
-                                     (list (procedure-reduce-arity p 1) 1 req allowed)
-                                     (list (procedure-reduce-arity p '()) '() req allowed))
-                                 (if (procedure-arity-includes? p 1)
-                                     (list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed)
-                                     (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed))))))
-                       procs)
-                  ;; reduce to arity 0 or nothing:
-                  (map (lambda (p)
-                         (let ([p (car p)])
-                           (let-values ([(req allowed) (procedure-keywords p)])
-                             (if (null? allowed)
-                                 (if (procedure-arity-includes? p 0)
-                                     (list (procedure-reduce-arity p 0) 0 req allowed)
-                                     (list (procedure-reduce-arity p '()) '() req allowed))
-                                 (if (procedure-arity-includes? p 0)
-                                     (list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed)
-                                     (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed))))))
-                       procs)
-                  ;; reduce to arity 1 or nothing --- no keywords:
-                  (map (lambda (p)
-                         (let ([p (car p)])
-                           (let-values ([(req allowed) (procedure-keywords p)])
-                             (if (and (procedure-arity-includes? p 1)
-                                      (null? req))
-                                 (list* (procedure-reduce-arity p 1) 1 '() '()
-                                        (if (null? allowed)
-                                            null
-                                            (list allowed)))
-                                 (list (procedure-reduce-arity p '()) '() '() '())))))
-                       procs)
-                  ;; reduce to arity 0 or nothing --- no keywords:
-                  (map (lambda (p)
-                         (let ([p (car p)])
-                           (let-values ([(req allowed) (procedure-keywords p)])
-                             (if (and (procedure-arity-includes? p 0)
-                                      (null? req))
-                                 (list (procedure-reduce-arity p 0) 0 '() '())
-                                 (list (procedure-reduce-arity p '()) '() '() '())))))
-                       procs)
-                  ;; make #:a required, if possible:
-                  (map (lambda (p)
-                         (let-values ([(req allowed) (procedure-keywords (car p))])
-                           (let ([new-req (if (member '#:a req)
-                                              req
-                                              (cons '#:a req))])
-                             (list (procedure-reduce-keyword-arity 
-                                    (car p)
-                                    (cadr p)
-                                    new-req
-                                    allowed)
-                                   (cadr p)
-                                   new-req
-                                   allowed))))
-                       (filter (lambda (p)
-                                 (let-values ([(req allowed) (procedure-keywords (car p))])
-                                   (or (not allowed)
-                                       (memq '#:a allowed))))
-                               procs))
-                  ;; remove #:b, if allowed and not required:
-                  (map (lambda (p)
-                         (let-values ([(req allowed) (procedure-keywords (car p))])
-                           (let ([new-allowed (if allowed
-                                                  (remove '#:b allowed)
-                                                  '(#:a))])
-                             (list* (procedure-reduce-keyword-arity 
-                                     (car p)
-                                     (cadr p)
-                                     req
-                                     new-allowed)
-                                    (cadr p)
-                                    req
-                                    new-allowed
-                                    (if allowed
-                                        (list allowed)
-                                        '())))))
-                       (filter (lambda (p)
-                                 (let-values ([(req allowed) (procedure-keywords (car p))])
-                                   (and (or (not allowed)
-                                            (memq '#:b allowed))
-                                        (not (memq '#:b req)))))
-                               procs))))
+(let ()
+  (define (try-combos procs add-chaperone) 
+    (for-each (lambda (p)
+                (let ([a (cadr p)])
+                  (test a procedure-arity (car p))
+                  (test-values (list (caddr p) (cadddr p))
+                               (lambda ()
+                                 (procedure-keywords (car p))))
+                  (let ([1-ok? (let loop ([a a])
+                                 (or (equal? a 1)
+                                     (and (arity-at-least? a)
+                                          ((arity-at-least-value a) . <= . 1))
+                                     (and (list? a)
+                                          (ormap loop a))))])
+                    (test 1-ok? procedure-arity-includes? (car p) 1)
+                    ;; While we're here test renaming, etc.:
+                    (test 'other object-name (procedure-rename (car p) 'other))
+                    (test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other))
+                    (test (procedure-arity (car p)) procedure-arity (procedure->method (car p)))
+                    (unless (null? (list-tail p 4))
+                      (test (object-name (list-ref p 4)) object-name (car p)))
+                    (let ([allowed (cadddr p)]
+                          [required (caddr p)])
+                      ;; If some keyword is required, make sure that a plain
+                      ;;  application fails:
+                      (unless (null? required)
+                        (err/rt-test
+                         (apply (car p) (make-list (procedure-arity (car p)) #\0))))
+                      ;; Other tests:
+                      (if 1-ok?
+                          (cond
+                           [(equal? allowed '())
+                            (test (let ([auto (let ([q (cddddr p)])
+                                                (if (null? q)
+                                                    q
+                                                    (cdr q)))])
+                                    (cond
+                                     [(equal? auto '((#:a #:b))) '(1 0 1)]
+                                     [(equal? auto '((#:a))) '(1 0)]
+                                     [(equal? auto '((#:a))) '(1 0)]
+                                     [else '(1)]))
+                                  (car p) 1)
+                            (err/rt-test ((car p) 1 #:a 0))
+                            (err/rt-test ((car p) 1 #:b 0))
+                            (err/rt-test ((car p) 1 #:a 0 #:b 0))]
+                           [(equal? allowed '(#:a))
+                            (test (if (and (pair? (cddddr p))
+                                           (pair? (cddddr (cdr p))))
+                                      '(10 20 1) ; dropped #:b
+                                      '(10 20))
+                                  (car p) 10 #:a 20)
+                            (err/rt-test ((car p) 1 #:b 0))
+                            (err/rt-test ((car p) 1 #:a 0 #:b 0))]
+                           [(equal? allowed '(#:b))
+                            (test '(10.0 20.0) (car p) 10.0 #:b 20.0)
+                            (err/rt-test ((car p) 1 #:a 0))
+                            (err/rt-test ((car p) 1 #:a 0 #:b 0))]
+                           [(equal? allowed '(#:a #:b))
+                            (test '(100 200 300) (car p) 100 #:b 300 #:a 200)
+                            (err/rt-test ((car p) 1 #:a 0 #:b 0 #:c 3))]
+                           [(equal? allowed #f)
+                            (test '(1 2 3) (car p) 1 #:b 3 #:a 2)])
+                          (begin
+                            ;; Try just 1:
+                            (err/rt-test ((car p) 1))
+                            ;; Try with right keyword args, to make sure the by-position
+                            ;; arity is checked:
+                            (cond
+                             [(equal? allowed '())
+                              (void)]
+                             [(equal? allowed '(#:a))
+                              (err/rt-test ((car p) 1 #:a 1))]
+                             [(equal? allowed '(#:b))
+                              (err/rt-test ((car p) 1 #:b 1))]
+                             [(equal? allowed '(#:a #:b))
+                              (err/rt-test ((car p) 1 #:a 1 #:b 1))]
+                             [(equal? allowed #f)
+                              (err/rt-test ((car p) 1 #:a 1 #:b 1))])))))))
+              (map
+               add-chaperone
+               (append procs
+                       ;; reduce to arity 1 or nothing:
+                       (map (lambda (p)
+                              (let ([p (car p)])
+                                (let-values ([(req allowed) (procedure-keywords p)])
+                                  (if (null? allowed)
+                                      (if (procedure-arity-includes? p 1)
+                                          (list (procedure-reduce-arity p 1) 1 req allowed p)
+                                          (list (procedure-reduce-arity p '()) '() req allowed p))
+                                      (if (procedure-arity-includes? p 1)
+                                          (list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed p)
+                                          (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
+                            procs)
+                       ;; reduce to arity 0 or nothing:
+                       (map (lambda (p)
+                              (let ([p (car p)])
+                                (let-values ([(req allowed) (procedure-keywords p)])
+                                  (if (null? allowed)
+                                      (if (procedure-arity-includes? p 0)
+                                          (list (procedure-reduce-arity p 0) 0 req allowed p)
+                                          (list (procedure-reduce-arity p '()) '() req allowed p))
+                                      (if (procedure-arity-includes? p 0)
+                                          (list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed p)
+                                          (list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
+                            procs)
+                       ;; reduce to arity 1 or nothing --- no keywords:
+                       (map (lambda (p)
+                              (let ([p (car p)])
+                                (let-values ([(req allowed) (procedure-keywords p)])
+                                  (if (and (procedure-arity-includes? p 1)
+                                           (null? req))
+                                      (list* (procedure-reduce-arity p 1) 1 '() '() p
+                                             (if (null? allowed)
+                                                 null
+                                                 (list allowed)))
+                                      (list (procedure-reduce-arity p '()) '() '() '() p)))))
+                            procs)
+                       ;; reduce to arity 0 or nothing --- no keywords:
+                       (map (lambda (p)
+                              (let ([p (car p)])
+                                (let-values ([(req allowed) (procedure-keywords p)])
+                                  (if (and (procedure-arity-includes? p 0)
+                                           (null? req))
+                                      (list (procedure-reduce-arity p 0) 0 '() '() p)
+                                      (list (procedure-reduce-arity p '()) '() '() '() p)))))
+                            procs)
+                       ;; make #:a required, if possible:
+                       (map (lambda (p)
+                              (let-values ([(req allowed) (procedure-keywords (car p))])
+                                (let ([new-req (if (member '#:a req)
+                                                   req
+                                                   (cons '#:a req))])
+                                  (list (procedure-reduce-keyword-arity 
+                                         (car p)
+                                         (cadr p)
+                                         new-req
+                                         allowed)
+                                        (cadr p)
+                                        new-req
+                                        allowed
+                                        (car p)))))
+                            (filter (lambda (p)
+                                      (let-values ([(req allowed) (procedure-keywords (car p))])
+                                        (or (not allowed)
+                                            (memq '#:a allowed))))
+                                    procs))
+                       ;; remove #:b, if allowed and not required:
+                       (map (lambda (p)
+                              (let-values ([(req allowed) (procedure-keywords (car p))])
+                                (let ([new-allowed (if allowed
+                                                       (remove '#:b allowed)
+                                                       '(#:a))])
+                                  (list* (procedure-reduce-keyword-arity 
+                                          (car p)
+                                          (cadr p)
+                                          req
+                                          new-allowed)
+                                         (cadr p)
+                                         req
+                                         new-allowed
+                                         (car p)
+                                         (if allowed
+                                             (list allowed)
+                                             '())))))
+                            (filter (lambda (p)
+                                      (let-values ([(req allowed) (procedure-keywords (car p))])
+                                        (and (or (not allowed)
+                                                 (memq '#:b allowed))
+                                             (not (memq '#:b req)))))
+                                    procs))))))
+  (try-combos procs values)
+  (let ([add-chaperone (lambda (p)
+                         (cons
+                          (chaperone-procedure
+                           (car p)
+                           (make-keyword-procedure
+                            (lambda (kws kw-args . rest)
+                              (if (null? kws)
+                                  (apply values rest)
+                                  (apply values kw-args rest)))))
+                          (cdr p)))])
+    (try-combos procs add-chaperone)
+    (try-combos (map add-chaperone procs) values)
+    (try-combos (map add-chaperone procs) add-chaperone)))
 
 ;; ----------------------------------------
 
diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt
index 1e0861912c..784b23e895 100644
--- a/doc/release-notes/mzscheme/HISTORY.txt
+++ b/doc/release-notes/mzscheme/HISTORY.txt
@@ -1,3 +1,6 @@
+Version 4.2.5.3
+Added chaperones
+
 Version 4.2.5, March 2010
 Added scheme/future, enabled by default on main platforms
 Changed module to wrap each body expression in a prompt
diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in
index acfe23dcd8..5f412baa37 100644
--- a/src/mred/gc2/Makefile.in
+++ b/src/mred/gc2/Makefile.in
@@ -215,7 +215,8 @@ xsrc/wx_xbm.cc: $(WXDIR)/utils/image/src/wx_xbm.cc $(XFORMDEP)
 MACXPRECOMP = macxsrc/xform_precomp.h
 MACXPRECOMPDEP = 
 
-macxsrc/xform_precomp.h : $(XFORMDEP) $(srcdir)/macprecomp.cxx $(srcdir)/../../mzscheme/src/schvers.h
+macxsrc/xform_precomp.h : $(XFORMDEP) $(srcdir)/macprecomp.cxx $(srcdir)/../../mzscheme/src/schvers.h \
+                          $(srcdir)/../../mzscheme/src/schemef.h
 	env XFORM_PRECOMP=yes $(XFORMXX) $(MACXPRECOMP) $(srcdir)/macprecomp.cxx
 
 @INCLUDEDEP@ macprecomp.dd
diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp
index 69ce8eb2cb..91f78c03b3 100644
--- a/src/mzscheme/include/mzscheme.exp
+++ b/src/mzscheme/include/mzscheme.exp
@@ -151,6 +151,7 @@ _scheme_apply_known_prim_closure
 _scheme_apply_known_prim_closure_multi
 _scheme_apply_prim_closure
 _scheme_apply_prim_closure_multi
+scheme_current_argument_stack
 scheme_call_with_prompt
 scheme_call_with_prompt_multi
 _scheme_call_with_prompt
diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp
index 17b5aed4c7..71c67b4651 100644
--- a/src/mzscheme/include/mzscheme3m.exp
+++ b/src/mzscheme/include/mzscheme3m.exp
@@ -151,6 +151,7 @@ _scheme_apply_known_prim_closure
 _scheme_apply_known_prim_closure_multi
 _scheme_apply_prim_closure
 _scheme_apply_prim_closure_multi
+scheme_current_argument_stack
 scheme_call_with_prompt
 scheme_call_with_prompt_multi
 _scheme_call_with_prompt
diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def
index ed148f3095..02bb57de57 100644
--- a/src/mzscheme/include/mzwin.def
+++ b/src/mzscheme/include/mzwin.def
@@ -145,6 +145,7 @@ EXPORTS
  scheme_eval_string_multi_with_prompt
  scheme_eval_string_all_with_prompt
  scheme_eval_module_string
+ scheme_current_argument_stack
  scheme_call_with_prompt
  scheme_call_with_prompt_multi
  scheme_values
diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def
index b8b2141e4b..2e4e43b6f2 100644
--- a/src/mzscheme/include/mzwin3m.def
+++ b/src/mzscheme/include/mzwin3m.def
@@ -145,6 +145,7 @@ EXPORTS
  scheme_eval_string_multi_with_prompt
  scheme_eval_string_all_with_prompt
  scheme_eval_module_string
+ scheme_current_argument_stack
  scheme_call_with_prompt
  scheme_call_with_prompt_multi
  scheme_values
diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c
index 463f87770a..405c73a616 100644
--- a/src/mzscheme/src/error.c
+++ b/src/mzscheme/src/error.c
@@ -991,7 +991,10 @@ static char *make_arity_expect_string(const char *name, int namelen,
       } else {
         Scheme_Object *v;
         int is_method;
-        v = scheme_extract_struct_procedure((Scheme_Object *)name, -1, NULL, &is_method);
+        v = (Scheme_Object *)name;
+        if (SCHEME_CHAPERONEP(v))
+          v = SCHEME_CHAPERONE_VAL(v);
+        v = scheme_extract_struct_procedure(v, -1, NULL, &is_method);
         if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
           break;
         name = (const char *)v;
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index 433b7df1e3..479584551e 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -9941,6 +9941,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 #endif
 }
 
+Scheme_Object **scheme_current_argument_stack()
+{
+  return MZ_RUNSTACK;
+}
+
 /*========================================================================*/
 /*                  eval/compile/expand starting points                   */
 /*========================================================================*/
diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c
index 21d48811fd..003123ba7e 100644
--- a/src/mzscheme/src/fun.c
+++ b/src/mzscheme/src/fun.c
@@ -3352,6 +3352,8 @@ Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
       /* Either use struct name, or extract proc, depending
          whether it's method-style */
       int is_method;
+      if (SCHEME_CHAPERONEP(a))
+        a = SCHEME_CHAPERONE_VAL(a);
       b = scheme_extract_struct_procedure(a, -1, NULL, &is_method);
       if (!is_method && SCHEME_PROCP(b)) {
         a = b;
@@ -4074,8 +4076,23 @@ static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Obje
 Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
 {
   Scheme_Chaperone *px = (Scheme_Chaperone *)o;
-  Scheme_Object *v, *a[1], *a2[1], **argv2, *post, *result_v;
-  int c, i;
+  Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v;
+  int c, i, need_restore = 0;
+
+  if (argv == MZ_RUNSTACK) {
+    /* Pushing onto the runstack ensures that px->redirects won't
+       modify argv. */
+    if (MZ_RUNSTACK > MZ_RUNSTACK_START) {
+      --MZ_RUNSTACK;
+      *MZ_RUNSTACK = NULL;
+      need_restore = 1;
+    } else {
+      /* Can't push! Just allocate a copy. */
+      argv2 = MALLOC_N(Scheme_Object *, argc);
+      memcpy(argv2, argv, sizeof(Scheme_Object*) * argc);
+      argv = argv2;
+    }
+  }
 
   v = _scheme_apply_multi(px->redirects, argc, argv);
   if (v == SCHEME_MULTIPLE_VALUES) {
@@ -4114,6 +4131,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
     return NULL;
   }
 
+  if (need_restore) {
+    /* As a step toward space safety, even clear out the arguments 
+       form the runstack: */
+    MZ_RUNSTACK++;
+    for (i = 0; i < argc; i++) {
+      argv[i] = NULL;
+    }
+  } else
+    argv = NULL;
+
   if (c == argc) {
     /* No filter for the result, so tail call: */
     if (auto_val) {
diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c
index fc04d7a1be..9ab63349db 100644
--- a/src/mzscheme/src/print.c
+++ b/src/mzscheme/src/print.c
@@ -2091,6 +2091,8 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
               print_utf8_string(pp, "procedure:", 0, 10);
               name = ((Scheme_Structure *)obj)->slots[2];
             } else {
+              if (SCHEME_PROCP(obj))
+                print_utf8_string(pp, "procedure:", 0, 10);
 	      name = SCHEME_STRUCT_NAME_SYM(obj);
             }
 
diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h
index ba1efbead8..4119ca7994 100644
--- a/src/mzscheme/src/schemef.h
+++ b/src/mzscheme/src/schemef.h
@@ -298,6 +298,8 @@ MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, int ar
 MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc,
 							  Scheme_Object **argv);
 
+MZ_EXTERN Scheme_Object **scheme_current_argument_stack();
+
 MZ_EXTERN Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
 MZ_EXTERN Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data);
 MZ_EXTERN Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h
index 17368b8e5d..beb3a3305d 100644
--- a/src/mzscheme/src/schemex.h
+++ b/src/mzscheme/src/schemex.h
@@ -243,6 +243,7 @@ Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
 						    Scheme_Object **argv);
 Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
 							  Scheme_Object **argv);
+Scheme_Object **(*scheme_current_argument_stack)();
 Scheme_Object *(*scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
 Scheme_Object *(*scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data);
 Scheme_Object *(*_scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc
index be68d0aecf..b1bffe1462 100644
--- a/src/mzscheme/src/schemex.inc
+++ b/src/mzscheme/src/schemex.inc
@@ -159,6 +159,7 @@
   scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi;
   scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure;
   scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_multi;
+  scheme_extension_table->scheme_current_argument_stack = scheme_current_argument_stack;
   scheme_extension_table->scheme_call_with_prompt = scheme_call_with_prompt;
   scheme_extension_table->scheme_call_with_prompt_multi = scheme_call_with_prompt_multi;
   scheme_extension_table->_scheme_call_with_prompt = _scheme_call_with_prompt;
diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h
index d3ee7e64da..dd3d1af0de 100644
--- a/src/mzscheme/src/schemexm.h
+++ b/src/mzscheme/src/schemexm.h
@@ -159,6 +159,7 @@
 #define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi)
 #define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure)
 #define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_multi)
+#define scheme_current_argument_stack (scheme_extension_table->scheme_current_argument_stack)
 #define scheme_call_with_prompt (scheme_extension_table->scheme_call_with_prompt)
 #define scheme_call_with_prompt_multi (scheme_extension_table->scheme_call_with_prompt_multi)
 #define _scheme_call_with_prompt (scheme_extension_table->_scheme_call_with_prompt)
diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c
index 3e9dd33ebe..589972109e 100644
--- a/src/mzscheme/src/struct.c
+++ b/src/mzscheme/src/struct.c
@@ -4347,7 +4347,7 @@ static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv)
   if (!SCHEME_PROCP(argv[0]))
     scheme_wrong_type("procedure-extract-target", "procedure", 0, argc, argv);
   
-  if (SCHEME_CHAPERONE_STRUCTP(argv[0])) {
+  if (SCHEME_STRUCTP(argv[0])) { /* don't allow chaperones */
     /* Don't expose arity reducer: */
     if (scheme_reduced_procedure_struct
         && scheme_is_struct_instance(scheme_reduced_procedure_struct, argv[0]))