Q&D puts remap

catch {rename puts console:oldputs$w}
  proc puts args [format {
    if {![winfo exists %s]} {
      rename puts {}
      rename console:oldputs%s puts
      return [uplevel #0 puts $args]
    }
    switch -glob -- "[llength $args] $args" {
      {1 *} {
         set msg [lindex $args 0]\n
         set tag ok
      }
      {2 stdout *} {
         set msg [lindex $args 1]\n
         set tag ok
      }
      {2 stderr *} {
         set msg [lindex $args 1]\n
         set tag err
      }
      {2 green *} {
         set msg [lindex $args 1]\n
         set tag grn
      }
      {2 purple *} {
         set msg [lindex $args 1]\n
         set tag purple
      }
      {2 lightblue *} {
         set msg [lindex $args 1]\n
         set tag lblue
      }
      {2 orange *} {
         set msg [lindex $args 1]\n
         set tag orange
      }
      {2 -nonewline *} {
         set msg [lindex $args 1]
         set tag ok
      }
      {3 -nonewline stdout *} {
         set msg [lindex $args 2]
         set tag ok
      }
      {3 -nonewline stderr *} {
         set msg [lindex $args 2]
         set tag err
      }
      default {
        uplevel #0 console:oldputs%s $args
        return
      }
    }
    console:Puts %s $msg $tag
  } $w $w $w $w.t]