diff --git a/pkgs/racket-doc/scribblings/reference/surrogate.scrbl b/pkgs/racket-doc/scribblings/reference/surrogate.scrbl
index d89eae7182..286060af3d 100644
--- a/pkgs/racket-doc/scribblings/reference/surrogate.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/surrogate.scrbl
@@ -14,8 +14,9 @@ so an object can completely change its behavior merely by changing the
 surrogate.
 
 @defform/subs[#:literals (augment override override-final)
-              (surrogate method-spec ...)
-              ([method-spec (augment method-id arg-spec ...)
+              (surrogate use-wrapper-proc method-spec ...)
+              ([use-wrapper-proc #:use-wrapper-proc (code:line)]
+               [method-spec (augment method-id arg-spec ...)
                             (override method-id arg-spec ...)               
                             (override-final method-id (lambda () default-expr) 
                                             arg-spec ...)]
@@ -29,9 +30,11 @@ The @racket[surrogate] form produces four values: a host mixin (a
 procedure that accepts and returns a class), a host interface, a
 surrogate class, and a surrogate interface.
 
-The host mixin adds one additional field, @racket[surrogate], to its
-argument. It also adds a getter method, @racket[get-surrogate], and a
-setter method, @racket[set-surrogate], for changing the field. The
+If @racket[#:use-wrapper-proc] does not appear,
+the host mixin adds one field @racket[surrogate].
+to its argument. It also adds getter and setter methods, @racket[get-surrogate],
+@racket[set-surrogate], @racket[get-surrogate-wrapper-proc], and
+@racket[set-surrogate-wrapper-proc] for changing the fields. The
 @racket[set-surrogate] method accepts instances of the class returned by
 the @racket[surrogate] form or @racket[#f], and it updates the field with its
 argument; then, @racket[set-surrogate] calls the @racket[on-disable-surrogate] on the
@@ -39,6 +42,24 @@ previous value of the field and @racket[on-enable-surrogate] for the
 new value of the field. The @racket[get-surrogate] method returns the
 current value of the field.
 
+If @racket[#:use-wrapper-proc] does appear, the the host mixin adds
+both the @racket[_surrogate] field (with its getters and setters) and a
+a second field, @racket[_surrogate-wrapper-proc] and its getter and setter
+methods, @racket[_get-surrogate-wrapper-proc] and @racket[_set-surrogate-wrapper-proc].
+The @racket[_surrogate-wrapper-proc] field holds a procedure whose contract
+is @racket[(-> (-> any) (-> any) any)]. The function is invoked with two thunks.
+The first one is a fallback that invokes the original object's method,
+skipping the surrogate. The other one invokes the surrogate.
+ @racketblock[(λ (fallback-thunk surrogate-thunk)
+                (surrogate-thunk))]
+which means that it simply defers to the method being invoked on the surrogate.
+The @racket[_surrogate-wrapper-proc] capability is part of the surrogate
+so that the dynamic extent of the calls to the surrogate can be adjusted
+(by, for example, changing the values of parameters). The
+@racket[_surrogate-wrapper-proc] is also invoked when calling the
+@racket[_on-disable-surrogate] and @racket[_on-enable-surrogate] methods
+of the surrogate.
+
 The host mixin has a single overriding method for each
 @racket[method-id] in the @racket[surrogate] form (even the ones
 specified with @racket[augment]. Each of these
diff --git a/pkgs/racket-test/tests/racket/surrogate.rkt b/pkgs/racket-test/tests/racket/surrogate.rkt
index 13705e7082..ba42dc8a72 100644
--- a/pkgs/racket-test/tests/racket/surrogate.rkt
+++ b/pkgs/racket-test/tests/racket/surrogate.rkt
@@ -64,3 +64,66 @@
   (send o set-surrogate #f)
 
   (check-equal? (send o m 2) 0))
+
+
+(let ()
+  (define-values (host-mixin host<%> surrogate% surrogate<%>)
+    (surrogate #:use-wrapper-proc
+               (override m ())
+               (override n x)))
+
+  (define p (make-parameter #f))
+
+  (define o
+    (new (host-mixin
+          (class object%
+            (define/public (m) (p))
+            (define/public (n . x) x)
+            (super-new)))))
+
+  (check-equal? (send o m) #f)
+
+  (send o set-surrogate
+        (new (class surrogate%
+               (define/override (m that that-m)
+                 (list (p) (that-m)))
+               (super-new))))
+
+  (check-equal? (send o m) (list #f #f))
+
+  (send o set-surrogate-wrapper-proc
+        (λ (fallback thunk)
+          (parameterize ([p #t])
+            (thunk))))
+
+  (check-equal? (send o m) (list #t #t))
+
+  (send o set-surrogate-wrapper-proc (λ (fallback thunk) (thunk)))
+  (send o set-surrogate
+        (new (class surrogate%
+               (define/override (m that that-m) 15)
+               (super-new))))
+
+  (check-equal? (send o m) 15)
+  
+  (send o set-surrogate-wrapper-proc (λ (fallback thunk) (fallback)))
+
+  (check-equal? (send o m) #f)
+
+  (send o set-surrogate-wrapper-proc (λ (fallback thunk) (thunk)))
+  
+  (check-equal? (send o n 1 2 3) '(1 2 3))
+  
+  (send o set-surrogate
+        (new (class surrogate%
+               (define/override (n that that-m . args) (cons 'surrogate args))
+               (super-new))))
+
+  (check-equal? (send o n 1 2 3) '(surrogate 1 2 3))
+
+  (send o set-surrogate-wrapper-proc (λ (fallback thunk) (cons 'wrapper (fallback))))
+
+  (check-equal? (send o n 1 2 3) '(wrapper 1 2 3))
+  
+  )
+
diff --git a/racket/collects/racket/surrogate.rkt b/racket/collects/racket/surrogate.rkt
index 8506054697..01116eaf20 100644
--- a/racket/collects/racket/surrogate.rkt
+++ b/racket/collects/racket/surrogate.rkt
@@ -1,158 +1,180 @@
 #lang racket/base
 
 (require racket/class
-         (for-syntax racket/base))
+         (for-syntax racket/base syntax/parse))
 
 (provide surrogate)
 
 (define-syntax (surrogate stx)
+
+  (define-splicing-syntax-class maybe-surrogate-wrapper
+    (pattern (~seq #:use-wrapper-proc)
+             #:with wrapper? #t)
+    (pattern (~seq)
+             #:with wrapper? #f))
   
-  (define (make-empty-method method-spec)
-    (syntax-case method-spec (override augment)
-      [(override name argspec ...)
-       (identifier? (syntax name))
-       (make-empty-method-from-argspec #'name (syntax (argspec ...)))]
-      [(augment def-expr name argspec ...)
-       (identifier? (syntax name))
-       (make-empty-method-from-argspec #'name (syntax (argspec ...)))]))
+  (syntax-parse stx
+    [(_ msw:maybe-surrogate-wrapper method-spec ...)
+
+     (define use-surrogate-wrapper-proc? (syntax-e #'msw.wrapper?))
+     
+     (define (make-empty-method method-spec)
+       (syntax-case method-spec (override augment)
+         [(override name argspec ...)
+          (identifier? (syntax name))
+          (make-empty-method-from-argspec #'name (syntax (argspec ...)))]
+         [(augment def-expr name argspec ...)
+          (identifier? (syntax name))
+          (make-empty-method-from-argspec #'name (syntax (argspec ...)))]))
   
-  (define (make-empty-method-from-argspec name argspecs)
-    (with-syntax ([(cases ...) (map make-empty-lambda-case
-                                    (syntax->list argspecs))]
-                  [name name])
-      (syntax
-       (begin
-         (define/public name
-           (case-lambda cases ...))))))
+     (define (make-empty-method-from-argspec name argspecs)
+       (with-syntax ([(cases ...) (map make-empty-lambda-case
+                                       (syntax->list argspecs))]
+                     [name name])
+         (syntax
+          (begin
+            (define/public name
+              (case-lambda cases ...))))))
   
-  (define (make-empty-lambda-case spec)
-    (syntax-case spec ()
-      [(id ...) (syntax [(ths super-call id ...) (super-call id ...)])]
-      [id
-       (identifier? (syntax id))
-       (syntax [(ths super-call . name) (apply super-call name)])]))
+     (define (make-empty-lambda-case spec)
+       (syntax-case spec ()
+         [(id ...) (syntax [(ths super-call id ...) (super-call id ...)])]
+         [id
+          (identifier? (syntax id))
+          (syntax [(ths super-call . name) (apply super-call name)])]))
   
-  (define (make-overriding-method method-spec)
-    (syntax-case method-spec (override augment)
-      [(override name argspec ...)
-       (identifier? (syntax name))
-       (make-overriding-method-with-inner-default 
-        #'name #f #'(argspec ...))]
-      [(augment def-expr name argspec ...)
-       (identifier? (syntax name))
-       (make-overriding-method-with-inner-default 
-        #'name #'def-expr #'(argspec ...))]))
+     (define (make-overriding-method method-spec)
+       (syntax-case method-spec (override augment)
+         [(override name argspec ...)
+          (identifier? (syntax name))
+          (make-overriding-method-with-inner-default 
+           #'name #f #'(argspec ...))]
+         [(augment def-expr name argspec ...)
+          (identifier? (syntax name))
+          (make-overriding-method-with-inner-default 
+           #'name #'def-expr #'(argspec ...))]))
   
-  (define (make-overriding-method-with-inner-default name def-expr argspecs)
-    ;; (not def-expr) => normal override
-    ;; def-expr => beta override
-    (let ([super-call-name
-           (datum->syntax 
-            name
-            (string->symbol
-             (string-append
-              (if def-expr
-                  "inner-proc-"
-                  "super-proc-")
-              (symbol->string
-               (syntax->datum
-                name)))))])
-      (with-syntax ([(cases ...) 
-                     (map (make-lambda-case name
-                                            super-call-name)
-                          (syntax->list argspecs))]
-                    [(super-proc-cases ...)
-                     (map (make-super-proc-case name def-expr)
-                          (syntax->list argspecs))]
-                    [super-call-name super-call-name]
-                    [name name]
-                    [ren/inn (if def-expr
-                                 #'inner
-                                 #'rename)]
-                    [define/override/fnl (if def-expr
-                                             #'define/augment
-                                             #'define/override)])
-        (syntax
-         (begin
-           (field [super-call-name
-                   (case-lambda super-proc-cases ...)])
-           (define/override/fnl name
-             (case-lambda cases ...)))))))
+     (define (make-overriding-method-with-inner-default name def-expr argspecs)
+       ;; (not def-expr) => normal override
+       ;; def-expr => beta override
+       (let ([super-call-name
+              (datum->syntax 
+               name
+               (string->symbol
+                (string-append
+                 (if def-expr
+                     "inner-proc-"
+                     "super-proc-")
+                 (symbol->string
+                  (syntax->datum
+                   name)))))])
+         (with-syntax ([(cases ...) 
+                        (map (make-lambda-case name
+                                               super-call-name)
+                             (syntax->list argspecs))]
+                       [(super-proc-cases ...)
+                        (map (make-super-proc-case name def-expr)
+                             (syntax->list argspecs))]
+                       [super-call-name super-call-name]
+                       [name name]
+                       [ren/inn (if def-expr
+                                    #'inner
+                                    #'rename)]
+                       [define/override/fnl (if def-expr
+                                                #'define/augment
+                                                #'define/override)])
+           (syntax
+            (begin
+              (field [super-call-name
+                      (case-lambda super-proc-cases ...)])
+              (define/override/fnl name
+                (case-lambda cases ...)))))))
   
-  (define ((extract-id stx) method-spec)
-    (syntax-case method-spec (override augment)
-      [(override name argspec ...)
-       (identifier? #'name)
-       (syntax name)]
-      [(augment result-expr name argspec ...)
-       (identifier? #'name)
-       (syntax name)]
-      [(override . whatever)
-       (raise-syntax-error
-        #f
-        "bad override method specification"
-        stx
-        method-spec)]
-      [(augment . whatever)
-       (raise-syntax-error
-        #f
-        "bad augment method specification"
-        stx
-        method-spec)]
-      [(id . whatever)
-       (identifier? #'id)
-       (raise-syntax-error
-        #f
-        "bad method specification, expected either override or augment"
-        stx
-        #'id)]
-      [whatever
-       (raise-syntax-error
-        #f
-        "bad method specification"
-        stx
-        method-spec)]))
+     (define ((extract-id stx) method-spec)
+       (syntax-case method-spec (override augment)
+         [(override name argspec ...)
+          (identifier? #'name)
+          (syntax name)]
+         [(augment result-expr name argspec ...)
+          (identifier? #'name)
+          (syntax name)]
+         [(override . whatever)
+          (raise-syntax-error
+           #f
+           "bad override method specification"
+           stx
+           method-spec)]
+         [(augment . whatever)
+          (raise-syntax-error
+           #f
+           "bad augment method specification"
+           stx
+           method-spec)]
+         [(id . whatever)
+          (identifier? #'id)
+          (raise-syntax-error
+           #f
+           "bad method specification, expected either override or augment"
+           stx
+           #'id)]
+         [whatever
+          (raise-syntax-error
+           #f
+           "bad method specification"
+           stx
+           method-spec)]))
   
-  (define (make-super-proc-case name def-expr)
-    (lambda (spec)
-      (with-syntax ([name name])
-        (syntax-case spec ()
-          ;; Not a rest arg: normal mode
-          [(id ...) (quasisyntax [(id ...)
-                                  (#,@(if def-expr 
-                                          (list #'inner def-expr)
-                                          (list #'super))
-                                   name
-                                   id ...)])]
-          ;; A rest arg: take args as list
-          [id 
-           (identifier? (syntax id))
-           (quasisyntax [(id) (#,@(if def-expr 
-                                      (list #'inner def-expr)
-                                      (list #'super))
-                               name
-                               . id)])]))))
+     (define (make-super-proc-case name def-expr)
+       (lambda (spec)
+         (with-syntax ([name name])
+           (syntax-case spec ()
+             ;; Not a rest arg: normal mode
+             [(id ...) (quasisyntax [(id ...)
+                                     (#,@(if def-expr 
+                                             (list #'inner def-expr)
+                                             (list #'super))
+                                      name
+                                      id ...)])]
+             ;; A rest arg: take args as list
+             [id 
+              (identifier? (syntax id))
+              (quasisyntax [(id) (#,@(if def-expr 
+                                         (list #'inner def-expr)
+                                         (list #'super))
+                                  name
+                                  . id)])]))))
   
-  (define (make-lambda-case name super-call)
-    (with-syntax ([name name]
-                  [super-call super-call])
-      (lambda (spec)
-        (syntax-case spec ()
-          ;; Not a rest arg: normal mode for super-call
-          [(id ...) (syntax [(id ...)
-                             (if the-surrogate
-                                 (send the-surrogate name this super-call id ...)
-                                 (super-call id ...))])]
-          ;; A rest arg: super-class takes args as a list
-          [id
-           (identifier? (syntax id))
-           (syntax [name 
-                    (if the-surrogate
-                        (send the-surrogate name this (lambda args (super-call args)) . id)
-                        (super-call id))])]))))
-  
-  (syntax-case stx ()
-    [(_ method-spec ...)
+     (define (maybe-call-surrogate-wrapper-proc id fallback-stx body-stx)
+       (if use-surrogate-wrapper-proc?
+           #`(surrogate-wrapper-proc
+              (λ () #,fallback-stx)
+              (let ([id (λ () #,body-stx)]) id))
+           body-stx))
+
+     (define (make-lambda-case name super-call)
+       (with-syntax ([name name]
+                     [super-call super-call])
+         (lambda (spec)
+           (syntax-case spec ()
+             ;; Not a rest arg: normal mode for super-call
+             [(id ...) #`[(id ...)
+                          (if the-surrogate
+                              #,(maybe-call-surrogate-wrapper-proc
+                                 #'name
+                                 #`(super-call id ...)
+                                 #`(send the-surrogate name this super-call id ...))
+                              (super-call id ...))]]
+             ;; A rest arg: super-class takes args as a list
+             [id
+              (identifier? (syntax id))
+              #`[name 
+                 (if the-surrogate
+                     #,(maybe-call-surrogate-wrapper-proc
+                        #'name
+                        #`(super-call name)
+                        #`(send the-surrogate name this (lambda args (super-call args)) . name))
+                     (super-call name))]]))))
+
      (with-syntax ([(ids ...) (map (extract-id stx) (syntax->list (syntax (method-spec ...))))]
                    [(overriding-methods ...)
                     (map make-overriding-method 
@@ -172,16 +194,32 @@
                 (interface ()
                   set-surrogate
                   get-surrogate
+                  #,@(if use-surrogate-wrapper-proc?
+                         (list #'set-surrogate-wrapper-proc
+                               #'get-surrogate-wrapper-proc)
+                         (list))
                   ids ...)])
            (values
             (λ (super%)
               (class* super% (host<%>)
                 (define the-surrogate #f)
+                #,(if use-surrogate-wrapper-proc?
+                      #'(begin
+                          (define surrogate-wrapper-proc always-do-the-call-surrogate-wrapper-proc)
+                          (define/public-final (set-surrogate-wrapper-proc _p)
+                            (check-surrogate-wrapper-proc _p)
+                            (set! surrogate-wrapper-proc _p))
+                          (define/public-final (get-surrogate-wrapper-proc)
+                            surrogate-wrapper-proc))
+                      #'(begin))
                 (define/public-final (set-surrogate new-surrogate)
                   (do-set-surrogate (λ (s) (set! the-surrogate s))
                                     the-surrogate
                                     this
                                     new-surrogate
+                                    #,(if use-surrogate-wrapper-proc?
+                                          #'surrogate-wrapper-proc
+                                          #'always-do-the-call-surrogate-wrapper-proc)
                                     '(ids ...)))
                 (define/public-final (get-surrogate) the-surrogate)
                 
@@ -199,9 +237,25 @@
                   (super-new)))
             surrogate<%>))))]))
 
-(define (do-set-surrogate set-the-surrogate the-surrogate this new-surrogate ids)
+(define (always-do-the-call-surrogate-wrapper-proc fallback main) (main))
+
+(define (check-surrogate-wrapper-proc p)
+  (unless (procedure-arity-includes? p 2)
+    (raise-argument-error 'set-surrogate-wrapper-proc
+                          "procedure of arity 2"
+                          p)))
+
+(define (do-set-surrogate set-the-surrogate
+                          the-surrogate
+                          this
+                          new-surrogate
+                          surrogate-wrapper-proc
+                          ids)
   (when the-surrogate
-    (send the-surrogate on-disable-surrogate this))
+    (surrogate-wrapper-proc
+     void
+     (λ ()
+       (send the-surrogate on-disable-surrogate this))))
 
   ;; error checking
   (when new-surrogate
@@ -217,4 +271,7 @@
 
   (set-the-surrogate new-surrogate)
   (when new-surrogate
-    (send new-surrogate on-enable-surrogate this)))
+    (surrogate-wrapper-proc
+     void
+     (λ ()
+       (send new-surrogate on-enable-surrogate this)))))