add more warning logging for contracts that don't have late-neg projections

racket/collects/racket/contract/private/misc.rkt

@@ -2147,13 +2147,6 @@
     (λ (x)
       (val+np-acceptor x #f))))
 
-(define (build-context)
-  (apply
-   string-append
-   (for/list ([i (in-list (continuation-mark-set->context
-                           (current-continuation-marks)))])
-     (format "\n  ~s" i))))
-
 (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
 (define (flat-named-contract name pre-contract [generate #f])
   (cond

racket/collects/racket/contract/private/prop.rkt

@@ -50,7 +50,9 @@
          prop:arrow-contract 
          prop:arrow-contract?
          prop:arrow-contract-get-info
-         (struct-out arrow-contract-info))
+         (struct-out arrow-contract-info)
+
+         build-context)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -253,6 +255,8 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define-logger racket/contract)
+
 (define ((build-property mk default-name proc-name first-order?)
          #:name [get-name #f]
          #:first-order [get-first-order #f]
@@ -272,7 +276,14 @@
      (string-append
       "expected either the #:get-projection, #:val-first-project, or #:late-neg-projection"
       " to not be #f, but all three were #f")))
-     
+
+  (unless get-late-neg-projection
+    (unless first-order?
+      (log-racket/contract-warning
+       "no late-neg-projection passed to ~s~a"
+       proc-name
+       (build-context))))
+
   (mk (or get-name (λ (c) default-name))
       (or get-first-order get-any?)
       get-projection
@@ -289,6 +300,13 @@
         [else get-late-neg-projection])
       list-contract?))
 
+(define (build-context)
+  (apply
+   string-append
+   (for/list ([i (in-list (continuation-mark-set->context
+                           (current-continuation-marks)))])
+     (format "\n  ~s" i))))
+    
 (define build-contract-property
   (procedure-rename
    (build-property make-contract-property 'anonymous-contract 'build-contract-property #f)
@@ -410,7 +428,7 @@
    #:exercise (lambda (c) (make-flat-contract-exercise c))
    #:list-contract? (λ (c) (make-flat-contract-list-contract? c))))
 
-(define ((build-contract mk default-name)
+(define ((build-contract mk default-name proc-name)
          #:name [name #f]
          #:first-order [first-order #f]
          #:projection [projection #f]
@@ -421,6 +439,12 @@
          #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
          #:list-contract? [list-contract? (λ (ctc) #f)])
 
+  (unless late-neg-projection
+    (log-racket/contract-warning
+     "no late-neg-projection passed to ~s~a"
+     proc-name
+     (build-context)))
+
   (mk (or name default-name)
       (or first-order any?) 
       projection val-first-projection late-neg-projection
@@ -447,17 +471,21 @@
 
 (define make-contract
   (procedure-rename 
-   (build-contract make-make-contract 'anonymous-contract)
+   (build-contract make-make-contract 'anonymous-contract 'make-contract)
    'make-contract))
 
 (define make-chaperone-contract
   (procedure-rename
-   (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract)
+   (build-contract make-make-chaperone-contract
+                   'anonymous-chaperone-contract
+                   'make-chaperone-contract)
    'make-chaperone-contract))
 
 (define make-flat-contract
   (procedure-rename
-   (build-contract make-make-flat-contract 'anonymous-flat-contract)
+   (build-contract make-make-flat-contract
+                   'anonymous-flat-contract
+                   'make-flat-contract)
    'make-flat-contract))
 
 ;; property should be bound to a function that accepts the contract and