diff --git a/pkgs/racket-doc/scribblings/reference/contract-util.rkt b/pkgs/racket-doc/scribblings/reference/contract-util.rkt
new file mode 100644
index 0000000000..ba361b2aba
--- /dev/null
+++ b/pkgs/racket-doc/scribblings/reference/contract-util.rkt
@@ -0,0 +1,27 @@
+#lang racket/base
+(require scribble/manual)
+
+(provide add-use-sources declare-exporting-ctc)
+
+(define-syntax-rule
+  (add-use-sources (x y ...))
+  (x y ...
+     #:use-sources
+     (racket/contract/private/base
+      racket/contract/private/misc
+      racket/contract/private/provide
+      racket/contract/private/guts
+      racket/contract/private/prop
+      racket/contract/private/blame
+      racket/contract/private/ds
+      racket/contract/private/opt
+      racket/contract/private/basic-opters
+      
+      racket/contract/private/box
+      racket/contract/private/hash
+      racket/contract/private/vector
+      racket/contract/private/struct-dc)))
+
+(define-syntax-rule
+  (declare-exporting-ctc mod)
+  (add-use-sources (declare-exporting mod racket/contract racket)))
diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt
index d995ad3f13..3f467e29f5 100644
--- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt
+++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt
@@ -996,6 +996,60 @@
                (provide a)))
       (eval '(dynamic-require ''provide/contract51-m2 'a)))
    '(1 2 3 4))
+
+  (test/spec-passed/result
+   'provide/contract52
+   '(let ()
+      (eval '(module provide/contract52-m1 racket/base
+               (require racket/contract/base)
+               (provide (contract-out
+                         [f (->* (integer?) (boolean? char? any/c) any)]))
+               (define (f x [y #f] [z #\a] [w 0]) (list x y z w))))
+      (eval '(module provide/contract52-m2 racket/base
+               (require 'provide/contract52-m1)
+               (provide a)
+               (define a
+                 (let ([f f])
+                   (list (f 1 #t #\x)
+                         (f 1))))))
+      (eval '(dynamic-require ''provide/contract52-m2 'a)))
+   '((1 #t #\x 0) (1 #f #\a 0)))
+
+  (test/spec-passed/result
+   'provide/contract53
+   '(let ()
+      (eval '(module provide/contract53-m1 racket/base
+               (require racket/contract/base)
+               (provide (contract-out
+                         [f (->* (integer?) (boolean? char? any/c) #:rest any/c any)]))
+               (define (f x [y #f] [z #\a] [w 0] . rest) (list* x y z w rest))))
+      (eval '(module provide/contract53-m2 racket/base
+               (require 'provide/contract53-m1)
+               (provide a)
+               (define a
+                 (let ([f f])
+                   (list (f 1 #t #\x 11 22 33 44 55 66)
+                         (f 1))))))
+      (eval '(dynamic-require ''provide/contract53-m2 'a)))
+   '((1 #t #\x 11 22 33 44 55 66) (1 #f #\a 0)))
+
+  (test/spec-passed/result
+   'provide/contract54
+   '(let ()
+      (eval '(module provide/contract54-m1 racket/base
+               (require racket/contract/base)
+               (provide (contract-out
+                         [f (->* (#:x integer?) (#:y boolean? #:z char? #:w any/c) any)]))
+               (define (f #:x x #:y [y #f] #:z [z #\a] #:w [w 0]) (list x y z w))))
+      (eval '(module provide/contract54-m2 racket/base
+               (require 'provide/contract54-m1)
+               (provide a)
+               (define a
+                 (let ([f f])
+                   (list (f #:x 1 #:y #t #:z #\x)
+                         (f #:x 1))))))
+      (eval '(dynamic-require ''provide/contract54-m2 'a)))
+   '((1 #t #\x 0) (1 #f #\a 0)))
   
   (contract-error-test
    'contract-error-test8
diff --git a/racket/collects/racket/contract/private/application-arity-checking.rkt b/racket/collects/racket/contract/private/application-arity-checking.rkt
index f8cf5ec8a9..bc6e651230 100644
--- a/racket/collects/racket/contract/private/application-arity-checking.rkt
+++ b/racket/collects/racket/contract/private/application-arity-checking.rkt
@@ -1,5 +1,5 @@
 #lang racket/base
-
+(require (for-template racket/base))
 #|
 
 Used to check an application site of a well-known
@@ -13,7 +13,8 @@ a valid-app-shape.
 |#
 
 (provide (struct-out valid-app-shapes)
-         valid-argument-list?)
+         valid-argument-list?
+         generate-medium-speed-wrapper)
 
 ;; valid-arities : (or/c (listof nat) (improper-listof nat))
 ;;    -- if improper, then the last nat indicates that any number
@@ -63,6 +64,42 @@ a valid-app-shape.
      ans?]
     [else #t]))
 
+;; called in the case that the identifier isn't used directly in an
+;; application. Try to generate a case-lambda that can still avoid
+;; the chaperone creation
+(define (generate-medium-speed-wrapper the-valid-app-shape
+                                       chaperone-expr
+                                       extra-arg-function
+                                       neg-party-id
+                                       add-medium-speed-kwd-wrapper-id
+                                       expected-name)
+  (cond
+    [(and the-valid-app-shape
+          (null? (valid-app-shapes-mandatory-kwds the-valid-app-shape))
+          (null? (valid-app-shapes-optional-kwds the-valid-app-shape)))
+     (define chaperone-expr-id (car (generate-temporaries '(medium-speed-wrapper))))
+     (define (mk-n-ids n) (generate-temporaries (build-list n (λ (x) 'medium-speed-wrapper-arg))))
+     (define case-lambda-clauses
+       (let loop ([valid-arities (valid-app-shapes-valid-arities the-valid-app-shape)])
+         (cond
+           [(null? valid-arities)
+            (list #`[args (apply #,chaperone-expr-id args)])]
+           [(number? valid-arities)
+            (with-syntax ([(x ...) (mk-n-ids valid-arities)]
+                          [(rest-arg) (generate-temporaries '(medium-speed-wrapper-dot-arg))])
+              (list
+               #`[(x ... . rest-arg) (apply #,extra-arg-function #,neg-party-id x ... rest-arg)]))]
+           [else
+            (with-syntax ([(x ...) (mk-n-ids (car valid-arities))])
+              (cons #`[(x ...) (#,extra-arg-function #,neg-party-id x ...)]
+                    (loop (cdr valid-arities))))])))
+     #`(let ([#,chaperone-expr-id #,chaperone-expr])
+         (#,add-medium-speed-kwd-wrapper-id
+          #,chaperone-expr-id
+          (let ([#,expected-name (case-lambda #,@case-lambda-clauses)])
+            #,expected-name)))]
+    [else chaperone-expr]))
+
 (define-logger optimizer)
 (define (log-problem stx)
   (log-optimizer-warning 
diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt
index 066c37d0f9..1469936117 100644
--- a/racket/collects/racket/contract/private/provide.rkt
+++ b/racket/collects/racket/contract/private/provide.rkt
@@ -88,7 +88,8 @@
     (saved-ho-id-table
      partially-applied-id
      extra-neg-party-argument-fn
-     valid-argument-lists)
+     valid-argument-lists
+     ex-id)
     #:property
     prop:set!-transformer
     (λ (self stx)
@@ -96,8 +97,9 @@
             [saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)]
             [extra-neg-party-argument-fn 
              (provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]
-            [valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)]
-            [rename-id (provide/contract-info-rename-id self)])
+            [the-valid-arg-shapes (provide/contract-arrow-transformer-valid-argument-lists self)]
+            [rename-id (provide/contract-info-rename-id self)]
+            [ex-id (provide/contract-arrow-transformer-ex-id self)])
         (with-syntax ([partially-applied-id partially-applied-id]
                       [extra-neg-party-argument-fn extra-neg-party-argument-fn])
           (if (eq? 'expression (syntax-local-context))
@@ -124,7 +126,15 @@
                            (add-rename-id rename-id
                             (syntax-local-lift-expression
                              (add-lifted-property
-                              #'(partially-applied-id lifted-neg-party))))))))
+                              (generate-medium-speed-wrapper
+                               the-valid-arg-shapes
+                               #'(partially-applied-id lifted-neg-party)
+                               (add-neg-party (add-rename-id
+                                               rename-id
+                                               #'extra-neg-party-argument-fn))
+                               #'lifted-neg-party
+                               #'add-medium-speed-kwd-wrapper
+                               ex-id))))))))
                   (when key (hash-set! saved-ho-id-table key lifted-ctc-val))
                   (adjust-location (syntax-local-introduce lifted-ctc-val)))
                 (syntax-case stx (set!)
@@ -138,7 +148,7 @@
                     stx #'id)]
                   [(name more ...)
                    (with-syntax ([app (datum->syntax stx '#%app)])
-                     (if (valid-argument-list? stx valid-arg-lists)
+                     (if (valid-argument-list? stx the-valid-arg-shapes)
                          (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
                            (adjust-location
                             #`(app #,(add-neg-party (add-rename-id
@@ -209,12 +219,27 @@
                  #`(app #,id args ...))]
               [x (identifier? #'x) id])))))
   
-  (define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val)
+  (define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val ex-id)
     (provide/contract-arrow-transformer rename-id
                                         contract-id id
                                         (make-hasheq)
-                                        pai enpfn val)))
+                                        pai enpfn val ex-id)))
 
+(define (add-medium-speed-kwd-wrapper chapone-contracted-proc no-keywords-path)
+  (make-keyword-procedure
+   (λ (kwds kwd-args . args)
+     (keyword-apply chapone-contracted-proc kwds kwd-args args))
+   no-keywords-path))
+
+(define-syntax (maybe-add-name stx)
+  (syntax-case stx ()
+    [(_ expr)
+     (let ()
+       (define name (syntax-local-name))
+       (printf "name! ~s\n" name)
+       (if (symbol? name)
+           #`(let ([#,name expr]) #,name)
+           #'expr))]))
 
 ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
 ;; given the syntax for an identifier and a contract,
@@ -317,7 +342,8 @@
                    (quote-syntax contract-id) (quote-syntax id)
                    (quote-syntax partially-applied-id)
                    (quote-syntax extra-neg-party-argument-fn)
-                   #,the-valid-app-shapes)
+                   #,the-valid-app-shapes
+                   '#,ex-id)
                 #`(make-provide/contract-transformer
                    (quote-syntax #,id-rename)
                    (quote-syntax contract-id) (quote-syntax id)