Fix more missing parties in contract instrumentation.

pkgs/racket-test/tests/racket/contract/prof.rkt

@@ -196,4 +196,18 @@
                                       [x pos-blame?]
                                       [y (x) #:depends-on-state pos-blame?]))
                  (λ (x) x) 'pos 'neg)
-       (posn 1 2)))))
+       (posn 1 2))))
+
+  (test/spec-passed
+   'provide/contract21
+   '(let ()
+      ((contract (case-> (-> any/c any/c pos-blame?))
+                 (λ (x y) x) 'pos 'neg)
+       1 2)))
+
+  (test/spec-passed
+   'provide/contract22
+   '(let ()
+      ((contract (case-> (-> neg-blame? any/c))
+                 (λ (x) x) 'pos 'neg)
+       1))))

racket/collects/racket/contract/private/case-arrow.rkt

@@ -2,6 +2,7 @@
 
 (require (for-syntax racket/base
                      syntax/name)
+         (only-in racket/list last)
          racket/stxparam
          "guts.rkt"
          "blame.rkt"
@@ -148,7 +149,9 @@
     (make-keyword-procedure
      (raise-no-keywords-error f blame neg-party)
      (λ args
-       (with-contract-continuation-mark blame (apply the-case-lam args)))))
+       (with-contract-continuation-mark
+        (cons blame neg-party)
+        (apply the-case-lam args)))))
   (define same-rngs (same-range-projections range-projections))
   (if same-rngs
       (wrapper
@@ -206,7 +209,9 @@
                                          (let* ([p   (f rng-blame)]
                                                 [new (lambda args
                                                        (with-contract-continuation-mark
-                                                        blame (apply p args)))])
+                                                        ;; last arg is missing party
+                                                        (cons blame (last args))
+                                                        (apply p args)))])
                                            (set! memo (cons (cons f new) memo))
                                            new))))
                                  rng-late-neg-ctcs)))

racket/collects/racket/contract/private/guts.rkt

@@ -607,6 +607,8 @@
 
 (define-syntax-rule (with-contract-continuation-mark payload code)
   (begin
+    ;; ;; When debugging a missing blame party error, turn this on, then run
+    ;; ;; the contract test suite. It should find the problematic combinator.
     ;; (unless (or (pair? payload) (not (blame-missing-party? payload)))
     ;;   (error "internal error: missing blame party" payload))
     (with-continuation-mark contract-continuation-mark-key payload code)))