diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index a8972cf30e..5600e6f94b 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -1768,64 +1768,6 @@ v4 todo:
     (append acc x)))
 
 
-
-;                       
-;                       
-;                       
-;                       
-;    ;          ;;; ;;; 
-;  ;;;              ;;; 
-;  ;;;;  ;;;;;  ;;; ;;; 
-;  ;;;; ;;;;;;; ;;; ;;; 
-;  ;;;  ;;  ;;; ;;; ;;; 
-;  ;;;    ;;;;; ;;; ;;; 
-;  ;;;  ;;; ;;; ;;; ;;; 
-;  ;;;; ;;; ;;; ;;; ;;; 
-;   ;;;  ;;;;;; ;;; ;;; 
-;                       
-;                       
-;                       
-;                       
-
-(define-syntax (apply-projections stx)
-  (syntax-case stx ()
-    [(_ ((x f) ...) e) 
-     (with-syntax ([count (length (syntax->list #'(x ...)))])
-       #'(let ([fs (list f ...)]
-               [thunk (λ () e)])
-           (call-with-immediate-continuation-mark
-            multiple-contract-key
-            (λ (first-mark)
-              (if (and first-mark
-                       (= (length first-mark) count)
-                       (andmap procedure-closure-contents-eq? fs first-mark))
-                  (thunk)
-                  (let-values ([(x ...) (with-continuation-mark multiple-contract-key fs
-                                          (thunk))])
-                    (values/drop (f x) ...)))))))]))
-
-
-(define multiple-contract-key (gensym 'multiple-contract-key))
-
-(define-syntax (apply-projection stx)
-  (syntax-case stx ()
-    [(_ ctc arg)
-     #'(apply-projection/proc ctc (λ () arg))]))
-
-(define single-contract-key (gensym 'single-contract-key))
-
-(define (apply-projection/proc ctc thnk)
-  (call-with-immediate-continuation-mark
-   single-contract-key
-   (λ (first-mark)  ;; note this is #f if there is no mark (so if #f can be a contract, something must change)
-     (if (and first-mark (procedure-closure-contents-eq? first-mark ctc))
-         (thnk)
-         (ctc
-          (with-continuation-mark single-contract-key ctc
-            (thnk)))))))
-
-
-
 ;                                                                                 
 ;                                                                                 
 ;                                                                                 
diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt
index 35e9566484..aca87b6150 100644
--- a/collects/racket/contract/private/opt-guts.rkt
+++ b/collects/racket/contract/private/opt-guts.rkt
@@ -9,7 +9,7 @@
 (provide get-opter reg-opter! opter
          interleave-lifts
          
-         make-opt/info
+         build-opt/info
          opt/info-contract
          opt/info-val
          opt/info-blame
@@ -22,6 +22,7 @@
          opt/info-swap-blame
          opt/info-add-blame-context
          opt/info-change-val
+         opt/info-positive-blame
          
          opt/unknown
          opt-error-name
@@ -148,13 +149,22 @@
 
 ;; struct for color-keeping across opters
 (define-struct opt/info
-  (contract val blame-stx swap-blame? free-vars recf base-pred this that))
+  (contract val blame-original-id blame-stx swap-blame? free-vars recf base-pred this that))
+(define (build-opt/info contract val blame-id free-vars this that)
+  (make-opt/info contract val blame-id blame-id #f free-vars #f #f this that))
 
 (define (opt/info-blame oi)
   (if (opt/info-swap-blame? oi)
     #`(blame-swap #,(opt/info-blame-stx oi))
     (opt/info-blame-stx oi)))
 
+;; returns syntax that, when evaluated, computes
+;; the name of the positive blame party
+(define (opt/info-positive-blame oi)
+  (if (opt/info-swap-blame? oi)
+      #`(blame-positive #,(opt/info-blame-original-id oi))
+      #`(blame-negative #,(opt/info-blame-original-id oi))))
+
 ;; opt/info-swap-blame : opt/info -> opt/info
 ;; swaps pos and neg
 (define (opt/info-swap-blame info)
diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt
index 52da4fdd0c..b24c6d06b4 100644
--- a/collects/racket/contract/private/opt.rkt
+++ b/collects/racket/contract/private/opt.rkt
@@ -229,7 +229,7 @@
          (values #'e (syntax-e #'x)))]))
   
   (parameterize ([opt-error-name error-name-sym])
-    (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
+    (define info (build-opt/info #'ctc #'val #'blame '() #'this #'that))
     (define an-optres (opt/i info exp #:call-opt/unknown? #f))
     (if an-optres
         (bind-superlifts
@@ -258,7 +258,7 @@
      (cond
        [(top-level-unknown? #'e) #'(otherwise-id e val-e blame-e)]
        [else
-        (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
+        (define info (build-opt/info #'ctc #'val #'blame '() #'this #'that))
         (define an-optres (opt/i info #'e))
         #`(let ([val val-e]
                 [blame blame-e])
@@ -302,9 +302,9 @@
   (syntax-case stx ()
     [(_ f1 f2 no-neg-blame? (id args ...) e)
      (let ()
-       (define info (make-opt/info #'ctc #'val #'blame #f 
+       (define info (build-opt/info #'ctc #'val #'blame 
                                    (syntax->list #'(args ...)) 
-                                   #f #f #'this #'that))
+                                   #'this #'that))
        ;; it seems like this syntax-local-value can fail when expand-once
        ;; is called, but otherwise I think it shouldn't fail
        (define bx (syntax-local-value #'no-neg-blame? (λ () #f)))
diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt
index dd1645a353..797eb12e61 100644
--- a/collects/racket/contract/private/opters.rkt
+++ b/collects/racket/contract/private/opters.rkt
@@ -557,27 +557,39 @@
                      ((next-dom ...) next-doms)
                      (dom-len (length dom-vars))
                      (rng-len (length rng-vars))
-                     ((next-rng ...) next-rngs))
+                     ((next-rng ...) next-rngs)
+                     [(dom-vars ...) (generate-temporaries dom-vars)]
+                     [(cont-mark-value) (generate-temporaries '(cont-mark-value))])
          (define (values/maybe-one stx)
            (syntax-case stx ()
              [(x) #'x]
              [(x ...) #'(values x ...)]))
-         #`(let ([exact-proc (case-lambda
-                               [(dom-arg ...)
-                                (values
-                                 (case-lambda
-                                   [(rng-arg ...)
-                                    #,(values/maybe-one #'(next-rng ...))]
-                                   [args 
-                                    (bad-number-of-results blame val rng-len args)])
-                                 next-dom ...)]
-                               [args
-                                (bad-number-of-arguments blame val args dom-len)])])
+         #`(let* ([cont-mark-value (cons #,(opt/info-positive-blame opt/info) '#,rngs)]
+                  [exact-proc (case-lambda
+                                [(dom-arg ...)
+                                 (let-values ([(rng-checker dom-vars ...)
+                                               (values (case-lambda
+                                                         [(rng-arg ...)
+                                                          #,(values/maybe-one #'(next-rng ...))]
+                                                         [args 
+                                                          (bad-number-of-results blame val rng-len args)])
+                                                       next-dom ...)])
+                                   (call-with-immediate-continuation-mark
+                                    opt->/c-cm-key 
+                                    (λ (mark-value)
+                                      (if (equal? mark-value cont-mark-value)
+                                          (values dom-vars ...)
+                                          (values rng-checker
+                                                  dom-vars ...)))))]
+                                [args
+                                 (bad-number-of-arguments blame val args dom-len)])])
              (if (and (procedure? val)
                       (equal? dom-len (procedure-arity val))
                       (let-values ([(a b) (procedure-keywords val)])
                         (null? b)))
-                 (chaperone-procedure val exact-proc)
+                 (chaperone-procedure val exact-proc
+                                      impersonator-prop:application-mark 
+                                      (cons opt->/c-cm-key cont-mark-value))
                  (handle-non-exact-procedure val dom-len blame exact-proc))))
        (append lifts-doms lifts-rngs)
        (append superlifts-doms superlifts-rngs)
@@ -709,6 +721,8 @@
                              #:name name)
                (opt/unknown opt/i opt/info stx))))]))
 
+(define opt->/c-cm-key (gensym 'opt->/c-cm-key))
+
 (define (blame-add-nth-arg-context blame n)
   (blame-add-context blame
                      (format "the ~a argument of" (n->th n))))
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 2085d082d9..1729eff85a 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -186,17 +186,32 @@
   (define (test/pos-blame name expression) (test/spec-failed name expression 'pos))
   (define (test/neg-blame name expression) (test/spec-failed name expression 'neg))
 
+  (define-syntax (ctest/rewrite stx)
+    (syntax-case stx ()
+      [(_ expected name expression)
+       #'(begin
+           (contract-eval `(,test expected name expression))
+           (let/ec k
+             (contract-eval `(,test expected 
+                                    ',(string->symbol (format "~a+opt/c" name))
+                                    ,(rewrite 'expression k)))))]))
+  
   (define (test/well-formed stx)
     (contract-eval
      `(,test (void)
-            (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void)
-            ,stx)))
+             (let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void)
+             ,stx)))
 
   (define (test/no-error sexp)
     (contract-eval
-    `(,test (void)
-       eval
-       '(begin ,sexp (void)))))
+     `(,test (void)
+             eval
+             '(begin ,sexp (void))))
+    (let/ec k
+      (contract-eval
+       `(,test (void)
+               eval
+               '(begin ,(rewrite sexp k) (void))))))
 
   (define (test-flat-contract contract pass fail)
     (contract-eval `(,test #t flat-contract? ,contract))
@@ -13040,100 +13055,114 @@ so that propagation occurs.
           [() c]
           [(x) (set! c (+ c 1)) #t]))))
 
-  (ctest 1
-         'tail-arrow
-         (let ([c (counter)])
-           (letrec ([f
-                     (contract (-> any/c c)
-                               (λ (x) (if (zero? x) x (f (- x 1))))
-                               'pos
-                               'neg)])
-             (f 3))
-           (c)))
-
-  (ctest 1
-         'tail-unconstrained-domain-arrow
-         (let ([c (counter)])
-           (letrec ([f
-                     (contract (unconstrained-domain-> c)
-                               (λ (x) (if (zero? x) x (f (- x 1))))
-                               'pos
-                               'neg)])
-             (f 3))
-           (c)))
-
-  (ctest 2
-         'tail-multiple-value-arrow
-         (let ([c (counter)])
-           (letrec ([f
-                     (contract (-> any/c (values c c))
-                               (λ (x) (if (zero? x) (values x x) (f (- x 1))))
-                               'pos
-                               'neg)])
-             (f 3))
-           (c)))
-
-  (ctest 2
-         'tail-arrow-star
-         (let ([c (counter)])
-           (letrec ([f
-                     (contract (->* (any/c) () (values c c))
-                               (λ (x) (if (zero? x) (values x x) (f (- x 1))))
-                               'pos
-                               'neg)])
-             (f 3))
-           (c)))
-
-
-  (ctest 1
-         'case->-regular
-         (let ([c (counter)])
-           (letrec ([f
-                     (contract (case-> (-> any/c c)
-                                       (-> any/c any/c c))
-                               (case-lambda
-                                 [(x) (if (zero? x) x (f (- x 1)))]
-                                 [(x y) (f x)])
-                               'pos
-                               'neg)])
-             (f 4 1))
-           (c)))
-
-  (ctest 1
-         'case->-rest-args
-         (let ([c (counter)])
-           (letrec ([f
-                     (contract (case-> (-> any/c #:rest any/c c)
-                                       (-> any/c any/c #:rest any/c c))
-                               (case-lambda
-                                 [(x) (f x 1)]
-                                 [(x y . z) (if (zero? x) x (apply f (- x 1) y (list y y)))])
-                               'pos
-                               'neg)])
-             (f 4))
-           (c)))
-
-  (ctest '(1)
-         'mut-rec-with-any/c
-         (let ()
-           (define f
-             (contract (-> number? any/c)
-                       (lambda (x)
-                         (if (zero? x)
-                             (continuation-mark-set->list (current-continuation-marks) 'tail-test)
-                             (with-continuation-mark 'tail-test x
-                               (g (- x 1)))))
-                       'pos
-                       'neg))
-
-           (define g
-             (contract (-> number? any/c)
-                       (lambda (x)
-                         (f x))
-                       'pos
-                       'neg))
-
-           (f 3)))
+  (ctest/rewrite 1
+                 'tail-arrow
+                 (let ([c (counter)])
+                   (letrec ([f
+                             (contract (-> any/c c)
+                                       (λ (x) (if (zero? x) x (f (- x 1))))
+                                       'pos
+                                       'neg)])
+                     (f 3))
+                   (c)))
+  
+  (ctest/rewrite 1
+                 'tail-unconstrained-domain-arrow
+                 (let ([c (counter)])
+                   (letrec ([f
+                             (contract (unconstrained-domain-> c)
+                                       (λ (x) (if (zero? x) x (f (- x 1))))
+                                       'pos
+                                       'neg)])
+                     (f 3))
+                   (c)))
+  
+  (ctest/rewrite 2
+                 'tail-multiple-value-arrow
+                 (let ([c (counter)])
+                   (letrec ([f
+                             (contract (-> any/c (values c c))
+                                       (λ (x) (if (zero? x) (values x x) (f (- x 1))))
+                                       'pos
+                                       'neg)])
+                     (f 3))
+                   (c)))
+  
+  (ctest/rewrite 2
+                 'tail-arrow-star
+                 (let ([c (counter)])
+                   (letrec ([f
+                             (contract (->* (any/c) () (values c c))
+                                       (λ (x) (if (zero? x) (values x x) (f (- x 1))))
+                                       'pos
+                                       'neg)])
+                     (f 3))
+                   (c)))
+  
+  
+  (ctest/rewrite 1
+                 'case->-regular
+                 (let ([c (counter)])
+                   (letrec ([f
+                             (contract (case-> (-> any/c c)
+                                               (-> any/c any/c c))
+                                       (case-lambda
+                                         [(x) (if (zero? x) x (f (- x 1)))]
+                                         [(x y) (f x)])
+                                       'pos
+                                       'neg)])
+                     (f 4 1))
+                   (c)))
+  
+  (ctest/rewrite 1
+                 'case->-rest-args
+                 (let ([c (counter)])
+                   (letrec ([f
+                             (contract (case-> (-> any/c #:rest any/c c)
+                                               (-> any/c any/c #:rest any/c c))
+                                       (case-lambda
+                                         [(x) (f x 1)]
+                                         [(x y . z) (if (zero? x) x (apply f (- x 1) y (list y y)))])
+                                       'pos
+                                       'neg)])
+                     (f 4))
+                   (c)))
+  
+  (ctest/rewrite '(1)
+                 'mut-rec-with-any/c
+                 (let ()
+                   (define f
+                     (contract (-> number? any/c)
+                               (lambda (x)
+                                 (if (zero? x)
+                                     (continuation-mark-set->list (current-continuation-marks) 'tail-test)
+                                     (with-continuation-mark 'tail-test x
+                                       (g (- x 1)))))
+                               'something-that-is-not-pos
+                               'neg))
+                   
+                   (define g
+                     (contract (-> number? any/c)
+                               (lambda (x)
+                                 (f x))
+                               'also-this-is-not-pos
+                               'neg))
+                   
+                   (f 3)))
+  
+  
+  (test/pos-blame 
+   'different-blame=>cannot-drop-check
+   '((contract (-> integer? integer?)
+               (λ (x)
+                 ((contract (-> integer? integer?)
+                            (λ (x) #f)
+                            'pos
+                            'neg)
+                  x))
+               'abc
+               'def)
+     5))
 
   (test/pos-blame 'free-vars-change-so-cannot-drop-the-check
                   '(let ()